pax_global_header00006660000000000000000000000064121601552230014507gustar00rootroot0000000000000052 comment=5d376cf92e09845bcd45935a49302eeec6e6c840 bin_prot-109.30.00/000077500000000000000000000000001216015522300136355ustar00rootroot00000000000000bin_prot-109.30.00/.gitignore000066400000000000000000000001021216015522300156160ustar00rootroot00000000000000_build/ /setup.data /setup.log /*.exe /*.docdir /*.native /*.byte bin_prot-109.30.00/CHANGES.txt000066400000000000000000000061401216015522300154470ustar00rootroot000000000000002012-07-15: Rewrote README in Markdown and improved documentation. Eliminated new warnings available in OCaml 4.00. 2012-02-28: Improved portability by better supporting the C99-standard and non-GNU compilers. 2011-11-10: Improved portability to older glibc distributions. 2011-09-15: Fixes to improve package dependency resolution. 2011-07-04: Internal updates to sync with Jane Street. 2011-06-29: Fixed bigstring layout bug, which should only affect value comparisons with OCaml 3.12.1 or later. Made 64-bit detection more reliable on Mac OS X. 2010-03-20: Fixed linking of toplevels to require bigarrays. Improved compilation on Mac OS X. 2010-03-17: Fixed small name capture bug. 2009-12-21: Updated contact information. 2009-09-19: Added missing type cases for supporting variant types. Fixed handling of variance annotations. 2009-07-27: Fixed build problem with gcc 4.4 due to stricter checking for empty macro arguments. Thanks to Nobuyuki Tomiza for the patch! 2009-07-20: Merged tiny Jane Street improvements. 2009-07-03: Made byte swapping more portable. 2009-07-02: Added support for network byte order integers. 2009-04-22: Added macro support for all kinds of vectors (vec, float32_vec, float64_vec) and matrices (mat, float32_mat, float64_mat), and for bigstrings (bigstring). 2009-04-16: Fixed a bug leading to an exception when writing extremely large values (>4 GB buffer size). Does not cause data corruption. Switched to private types with "Nat0.t". Added support for converting vectors (Bigarrays). Added functor for generation of converters for "iterable" types. Some code cleanups. 2009-03-09: Synchronized with Jane Street version. 2009-03-02: Fixed another build problem on Mac OS X. 2008-10-16: Fixed build problem on Mac OS X. Thanks to Alexy Khrabrov for the patch! 2008-09-19: Fixed compilation problem in test suite. Fixed compilation problem on 32bit platforms. Fix bug in architecture detection. 2008-08-22: Removed deprecated functionality and addressed code reviews. 2008-08-20: Fixed build problems. Slightly improved API. 2008-07-28: Fixed 32bit compilation problem. 2008-05-16: Added reader for int64_bits + test cases for reader and writer. 2008-04-29: Final fixes before first public release. 2008-04-03: Added converter functor for types that should not be written out in their original extensional representation. 2008-03-18: Fixed minor bin_prot code generation bug with empty types. 2008-03-17: Improved META-file. 2008-02-11: Fixed code generation problems with variance annotations in signatures, and with empty types. 2007-12-18: Added support for bigstrings. 2007-12-17: Added support for signature generation. 2007-10-31: Synchronized with Jane Street version. 2007-10-11: Initial release. bin_prot-109.30.00/COPYRIGHT.txt000066400000000000000000000007721216015522300157540ustar00rootroot00000000000000Most of this library was written by: Markus Mottl Part of this work is derived from the library "Tywith", version 0.45. The library "Tywith" was written and is distributed by: Martin Sandin The original license of "Tywith" can be found in the file "LICENSE-Tywith.txt". The following company has sponsored and has copyright in part of this work: Jane Street Holding, LLC 1 New York Plaza, 33rd Floor New York, NY 10004 USA bin_prot-109.30.00/INRIA-DISCLAIMER.txt000066400000000000000000000013321216015522300166510ustar00rootroot00000000000000THIS SOFTWARE IS PROVIDED BY INRIA AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL INRIA OR ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. bin_prot-109.30.00/INSTALL.txt000066400000000000000000000017661216015522300155160ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: d6b0da1872572b37d4ff493dfc0f6ff9) *) This is the INSTALL file for the bin_prot distribution. This package uses OASIS to generate its build system. See section OASIS for full information. Dependencies ============ In order to compile this package, you will need: * ocaml (>= 4.00.0) for all, test mac_test, test test_runner, doc bin_prot * findlib (>= 1.3.2) * type_conv (>= 3.0.5) for library pa_bin_prot * oUnit (>= 1.0.2) for executable test_runner Installing ========== 1. Uncompress the source archive and go to the root of the package 2. Run 'ocaml setup.ml -configure' 3. Run 'ocaml setup.ml -build' 4. Run 'ocaml setup.ml -install' Uninstalling ============ 1. Go to the root of the package 2. Run 'ocaml setup.ml -uninstall' OASIS ===== OASIS is a program that generates a setup.ml file using a simple '_oasis' configuration file. The generated setup only depends on the standard OCaml installation: no additional library is required. (* OASIS_STOP *) bin_prot-109.30.00/LICENSE-Tywith.txt000066400000000000000000000030101216015522300167400ustar00rootroot00000000000000--------------------------------------------------------------------------- Copyright (c) 2004 Martin Sandin All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --------------------------------------------------------------------------- bin_prot-109.30.00/LICENSE.txt000066400000000000000000000261361216015522300154700ustar00rootroot00000000000000 Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. bin_prot-109.30.00/Makefile000066400000000000000000000025111216015522300152740ustar00rootroot00000000000000# Generic Makefile for oasis project # Set to setup.exe for the release SETUP := setup.exe # Default rule default: build # Setup for the development version setup-dev.exe: _oasis setup.ml sed '/^#/D' setup.ml > setup_dev.ml ocamlfind ocamlopt -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || ocamlfind ocamlc -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || true rm -f setup_dev.* # Setup for the release setup.exe: setup.ml ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< rm -f setup.cmx setup.cmi setup.o setup.obj setup.cmo build: $(SETUP) setup.data ./$(SETUP) -build $(BUILDFLAGS) doc: $(SETUP) setup.data build ./$(SETUP) -doc $(DOCFLAGS) test: $(SETUP) setup.data build ./$(SETUP) -test $(TESTFLAGS) all: $(SETUP) ./$(SETUP) -all $(ALLFLAGS) install: $(SETUP) setup.data ./$(SETUP) -install $(INSTALLFLAGS) uninstall: $(SETUP) setup.data ./$(SETUP) -uninstall $(UNINSTALLFLAGS) reinstall: $(SETUP) setup.data ./$(SETUP) -reinstall $(REINSTALLFLAGS) clean: $(SETUP) ./$(SETUP) -clean $(CLEANFLAGS) distclean: $(SETUP) ./$(SETUP) -distclean $(DISTCLEANFLAGS) configure: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) setup.data: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) .PHONY: default build doc test all install uninstall reinstall clean distclean configure bin_prot-109.30.00/README.md000066400000000000000000000415351216015522300151240ustar00rootroot00000000000000`Bin_prot` - OCaml Type Converter for Binary Protocols ====================================================== --------------------------------------------------------------------------- What is `Bin_prot`? ------------------- This library contains functionality for reading and writing OCaml-values in a type-safe binary protocol. It is extremely efficient, typically supporting type-safe marshalling and unmarshalling of even highly structured values at speeds sufficient to saturate a gigabit connection. The protocol is also heavily optimized for size, making it ideal for long-term storage of large amounts of data. The library is highly dependable and safe to use: a rigorous test suite has to date guaranteed that this library has never exhibited a bug in production systems in several years of use. `Bin_prot` has been successfully deployed in mission-critical financial applications, storing many terabytes of structured data derived from thousands of type definitions and typically processing millions of messages a day in realtime for low-latency applications that must not crash. Since version two this library should work with all CPU architectures currently supported by OCaml, no matter the word size (32 or 64 bit), alignment requirements, or endianness. Endianness defines the byte order in which machine representations of integers (machine words) are stored in main memory. `Bin_prot` provides users with a convenient and safe way of performing I/O on any extensionally defined OCaml type (see later sections for details). Functions, objects, first-class modules, as well as values whose type is bound through a polymorphic record field are hence not supported. This is hardly ever a limitation in practice. As of now, there is no support for cyclic or shared values. Cyclic values will lead to non-termination whereas shared values, besides requiring more space when encoded, may lead to a substantial increase in memory footprint when they are read back. It would not be trivial to support these kinds of values in a type-safe way without noticeably sacrificing performance. If these kinds of values are needed, the user may want to use the as of today still unsafe marshalling functions provided by OCaml. This library uses the machine stack for efficiency reasons. This can potentially lead to a crash if the stack limit is reached. Note that this is also a limitation of the (unsafe) standard marshalling functions shipped with OCaml. This problem can happen for large amounts of data if recursion in the type definition of the data structure is not limited to the last element. Only in the latter case will tail-recursion allow for (practically) unlimited amounts of data. If this exceedingly rare limitation ever turned out to be an issue in a user application, it can often be solved by redefining the data type to allow for tail-recursion. The limitation cannot be eliminated in this library without significant performance impact and increased complexity. Usage ----- The API (`.mli`-files) in the `bin_prot` library directory (`lib`) is fully documented, and HTML-documentation can be built from it on installation. The documentation for the latest release can also be found [online](http://mmottl.bitbucket.org/projects/bin_prot/api/). Module `Common` defines some globally used types, functions, exceptions, and values. `Nat0` implements natural numbers including zero. Modules `Read_ml` and `Write_ml` contain read and write functions respectively for all basic types and are implemented in OCaml as far as reasonable. Some operations are most easily performed in C. If you only want to read or write single, basic, unstructured values, using this module is probably the most efficient and convenient way of doing this. Otherwise you should annotate your type definitions to generate type converters automatically (see later sections for details). The preprocessor in `syntax/pa_bin_prot.ml` will then generate highly optimized functions for converting your OCaml-values to and from the binary representation. This automatically generated code will use functions in modules `Unsafe_common`, `Unsafe_read_c` and `Unsafe_write_c`, which employ unsafe internal representations to achieve optimal performance. The auto-generated code is extremely well-tested and should use these unsafe representations correctly. Developers who want to make manual use of these unsafe calling conventions for efficiency are strongly encouraged to test their code carefully. The module `Size` allows you to compute the size of basic OCaml-values in the binary representation before writing them to a buffer. The code generator will also provide you with functions for your user-defined types. Module `Std` predefines converters for most standard OCaml types. If you use the preprocessor macros to generate code from type definitions, make sure that the contents of this module is visible by e.g. adding the following at the top of files using this library: :::ocaml open Bin_prot.Std Note that you can shadow the definitions in the above module in the unlikely event that the predefined ways of converting data are unsatisfactory to you. The modules `Read_c` and `Write_c` wrap the unsafe low-level converters for basic values to ones accessible safely from within OCaml and vice versa. They also export functions for wrapping user-defined converters. This should help developers make their converters available in the respective other representation (low- or high-level). The test applications in the distribution use these wrappers to verify the correctness of implementations for low-level (C) and high-level (OCaml) representations. The module `Type_class` contains some extra definitions for type classes of basic values. These definitions can be passed to the function `bin_dump` in module `Utils` to marshal values into buffers of exact size using the binary protocol. However, if bounds on the size of values are known, it is usually more efficient to write them directly into preallocated buffers and just catch exceptions if the buffer limits are unexpectedly violated. Doing so should never cause a crash. That way one does not have to compute the size of the value, which can sometimes be almost as expensive as writing the value in the first place. In module `Utils` the function `bin_read_stream` can be used to efficiently read size-prefixed values as written by `bin_dump` with the `header` flag set to `true`. This module also offers several useful functors. The ones for `Binable` types help users create readers and writers if a type needs to be converted to or from some intermediate representation before marshalling or after unmarshalling respectively. The functors for `Iterable` types are helpful if some (usually abstract) data type offers iteration over elements and if the series of iterated-over elements alone is sufficient to reconstruct the original value. This allows for a more compact protocol and for robustness against changes to the internal representation of the data type (e.g. sets, maps, etc.). ### Examples Consider the following type definition: :::ocaml type t = A | B with bin_io This will generate the functions `bin_size_t`, `bin_write_t`, and `bin_read_t`, as well as the type class values `bin_writer_t`, `bin_reader_t`, and `bin_t`. If you use the annotation `bin_write` instead of `bin_io`, then only the write and size functions and their type class will be generated. Specifying `bin_read` will generate the read functions and associated type class only. The annotation `bin_type_class` will generate the combined type class only, thus allowing the user to easily define their own reader and writer type classes. The code generator may also generate low-level entry points used for efficiency or backtracking. The preprocessor can also generate signatures for conversion functions. Just add the wanted annotation to the type in a module signature for that purpose. Specification of the Binary Protocol ------------------------------------ The binary protocol does not contain any data other than the minimum needed to decode values. This means that the user is responsible for e.g. writing out the size of messages themselves if they want to be able to preallocate sufficiently sized buffers before reading. The `Utils` module provides some simple functions for that matter, though users may obtain optimum efficiency by managing buffers themselves. Basic OCaml-values are written out character-wise as described below. The specification uses hex codes to define the character encoding. Some of these values require size/length information to be written out before the value (e.g. for lists, hash tables, strings, etc.). Size information is always encoded as natural numbers (`Nat0.t`). The little-endian format is used in the protocol for the contents of integers on all platforms. The following definitions will be used in the encoding specifications below: :::text CODE_NEG_INT8 -> 0xff CODE_INT16 -> 0xfe CODE_INT32 -> 0xfd CODE_INT64 -> 0xfc ### Nat0.t This type encodes natural numbers including zero. It is frequently used by `Bin_prot` itself for encoding size information for e.g. lists, arrays, etc., and hence defined first here. Developers can reuse this type in their code, too, of course. If the value of the underlying integer is lower than a certain range, this implies a certain encoding as provided on the right hand side of the following definitions: :::text < 0x000000080 -> lower 8 bits of the integer (1 byte) < 0x000010000 -> CODE_INT16 followed by lower 16 bits of integer (3 bytes) < 0x100000000 -> CODE_INT32 followed by lower 32 bits of integer (5 bytes) >= 0x100000000 -> CODE_INT64 followed by all 64 bits of integer (9 bytes) The last line in the definitions above is only supported on 64 bit platforms due to word size limitations. Appropriate exceptions will be raised if there is an overflow, for example if a 64 bit encoding is read on a 32 bit platform, or if the 32 bit or 64 bit encoding overflowed the 30 bit or 62 bit capacity of natural numbers on their respective platforms. The last kind of overflow is due to OCaml reserving one bit for GC-tagging and the sign bit being lost. ### Unit values :::text () -> 0x00 ### Booleans :::text false -> 0x00 true -> 0x01 ### Strings First the length of the string is written out as a `Nat0.t`. Then the contents of the string is copied verbatim. ### Characters Characters are written out verbatim. ### Integers This includes all integer types: `int`, `int32`, `int64`, `nativeint`. If the value is positive (including zero) and if it is: :::text < 0x00000080 -> lower 8 bits of the integer (1 byte) < 0x00008000 -> CODE_INT16 followed by lower 16 bits of integer (3 bytes) < 0x80000000 -> CODE_INT32 followed by lower 32 bits of integer (5 bytes) >= 0x80000000 -> CODE_INT64 followed by all 64 bits of integer (9 bytes) If the value is negative and if it is: :::text >= -0x00000080 -> CODE_NEG_INT8 followed by lower 8 bits of integer (2 bytes) >= -0x00008000 -> CODE_INT16 followed by lower 16 bits of integer (3 bytes) >= -0x80000000 -> CODE_INT32 followed by lower 32 bits of integer (5 bytes) < -0x80000000 -> CODE_INT64 followed by all 64 bits of integer (9 bytes) All of the above branches will be considered when converting values of type `int64`. The case for `CODE_INT64` will only be considered with types `int` and `nativeint` if the architecture supports it. `int32` will never be encoded as a `CODE_INT64`. Appropriate exceptions will be raised if the architecture of or the type requested by the reader does not support some encoding or if there is an overflow. An overflow can only happen with values of type `int`, because one bit is reserved by OCaml for the GC-tag again. The reason for this peculiar encoding is of statistical nature. It was assumed that small or positive numbers are much more frequent in practice than big or negative ones. The code is biased accordingly to achieve good compression and decoding performance. For example, a positive integer in the range from `0` to `127` requires only a single byte on the wire and only a single branch to identify it. ### Floats Floats are written out according to the 64 bit IEEE 754 floating point standard, i.e. their memory representation is copied verbatim. ### References and lazy values Same as the binary encoding of the value in the reference or of the lazily calculated value. ### Option values If the value is: :::text None -> 0x00 Some v -> 0x01 followed by the encoding of v ### Tuples and records Values in tuples and records are written out one after the other in the order specified in the type definition. Polymorphic record fields are supported unless a value of the type bound by the field were accessed, which would lead to an exception. ### Sum types Each of the `n` tags in a sum type is assigned an integer from `0` to `n - 1` in exactly the same order as they occur in the type. If a value of this type needs to be written out, then if: :::text n <= 256 -> write out lower 8 bits of n (1 byte) n <= 65536 -> write out lower 16 bits of n (2 bytes) Sum types with more tags are currently not supported and highly unlikely to occur in practice. Arguments to the tag are written out in the order of occurrence. ### Polymorphic variants The tags of these values are written out as four characters, more precisely as the 32 bit hash value computed by OCaml for the given tag in little-endian format. Any arguments associated with the tag are written out afterwards in the order of occurrence. When polymorphic variants are being read, they will be matched in order of occurrence (left-to-right) in the type and depth-first in the case of included polymorphic types. The first type containing a match for the variant will be used for reading. E.g.: :::ocaml type ab = [ `A | `B ] with bin_io type cda = [ `C | `D | `A ] with bin_io type abcda = [ ab | cda ] with bin_io When reading type `abcda`, the reader associated with type `ab` rather than `cda` will be invoked if a value of type ```A`` can be read. This may not make a difference in this example, but is important to know if the user manually overrides converters. It is strongly recommended to not merge polymorphic variants if their readers might disagree about how to interpret a certain tag. This is inconsistent, confusing, and hard to debug. ### Lists and arrays For lists and arrays the length is written out as a `Nat0.t` first, followed by all values in the same order as in the data structure. ### Hash tables First the size of the hash table is written out as a `Nat0.t`. Then the writer iterates over each binding in the hash table and writes out the key followed by the value. Note that this makes reading somewhat slower than if we used the internal (extensional) representation of the hash table, because all values have to be rehashed. On the other hand, the format becomes more robust in case the hash table implementation changes. This has in fact already happened in practice with the release of OCaml 4.00. Users should take note of this and make sure that all of their serialization routines remain future-proof by defining wire formats that are independent of the implementation of abstract data types. ### Bigarrays of doubles (type `vec`) and characters (type `bigstring`) First the dimension(s) are written out as `Nat0.t`. Then the contents is copied verbatim. ### Polymorphic values There is nothing special about polymorphic values as long as there are conversion functions for the type parameters. E.g.: :::ocaml type 'a t = A | B of 'a with bin_io type foo = int t with bin_io In the above case the conversion functions will behave as if `foo` had been defined as a monomorphic version of `t` with `int` substituted for `'a` on the right hand side. ### Abstract data types If you want to convert an abstract data type that may impose constraints on the well-formedness of values, you will have to roll your own conversion functions. Use the functions in module `Read_c` and `Write_c` to map between low-level and high-level representations, or implement those manually for maximum efficiency. The `Utils` module may also come in handy as described in earlier sections, e.g. if the value can be converted to and from an intermediate representation that does not impose constraints, or if some sort of iteration is supported by the data type. --------------------------------------------------------------------------- Contact Information and Contributing ------------------------------------ In the case of bugs, feature requests, contributions and similar, please contact the maintainers: * Jane Street Capital, LLC Up-to-date information should be available at: * * bin_prot-109.30.00/THIRD-PARTY.txt000066400000000000000000000013601216015522300161450ustar00rootroot00000000000000The repository contains 3rd-party code in the following locations and under the following licenses: - type_conv, sexplib and bin_prot: based on Tywith, by Martin Sandin. License can be found in base/sexplib/LICENSE-Tywith.txt, base/type_conv/LICENSE-Tywith.txt, and base/bin_prot/LICENSE-Tywith.txt. - Core's implementation of union-find: based on an implementation by Henry Matthew Fluet, Suresh Jagannathan, and Stephen Weeks. License can be found in base/core/MLton-license. - Various Core libraries are based on INRIA's OCaml distribution. Relicensed under Apache 2.0, as permitted under the Caml License for Consortium members: http://caml.inria.fr/consortium/license.en.html See also the disclaimer INRIA-DISCLAIMER.txt. bin_prot-109.30.00/TODO.txt000066400000000000000000000000711216015522300151410ustar00rootroot00000000000000Testing: bin_write_int_{8,16,32,64}bit bin_size_... bin_prot-109.30.00/_oasis000066400000000000000000000062451216015522300150440ustar00rootroot00000000000000OASISFormat: 0.3 OCamlVersion: >= 4.00.0 FindlibVersion: >= 1.3.2 Name: bin_prot Version: 109.30.00 Synopsis: bin_prot - binary protocol generator Authors: Jane Street Capital LLC Copyrights: (C) 2008-2013 Jane Street Capital LLC Maintainers: Jane Street Capital LLC License: Apache-2.0 LicenseFile: LICENSE.txt Homepage: https://github.com/janestreet/bin_prot Plugins: StdFiles (0.3), DevFiles (0.3), META (0.3) XStdFilesAUTHORS: false XStdFilesREADME: false BuildTools: ocamlbuild, camlp4o Plugins: StdFiles (0.3), DevFiles (0.3), META (0.3) XStdFilesAUTHORS: false XStdFilesREADME: false PostConfCommand: config/arch.sh $ocamlc PreBuildCommand: mkdir -p _build; cp lib/*.mlh lib/*.h _build/ Library bin_prot Path: lib Pack: true Modules: Binable, Nat0, Common, Unsafe_common, Unsafe_write_c, Unsafe_read_c, Size, Write_ml, Read_ml, Write_c, Read_c, Std, Type_class, Map_to_safe, Utils CSources: common_stubs.c, common_stubs.h, int64_native.h, int64_emul.h, write_stubs.c, read_stubs.c BuildDepends: unix,bigarray Library pa_bin_prot Path: syntax FindlibName: syntax FindlibParent: bin_prot Modules: Pa_bin_prot BuildDepends: camlp4.quotations,camlp4.extend,type_conv (>= 3.0.5) XMETAType: syntax XMETARequires: camlp4,type_conv,bin_prot XMETADescription: Syntax extension for binary protocol generator Executable test_runner Path: lib_test MainIs: test_runner.ml Build$: flag(tests) Install: false CompiledObject: best Custom: true BuildDepends: bin_prot,bin_prot.syntax,oUnit (>= 1.0.2) Test test_runner Run$: flag(tests) Command: $test_runner WorkingDirectory: lib_test Executable mac_test Path: lib_test MainIs: mac_test.ml Build$: flag(tests) Install: false Custom: true CompiledObject: best BuildDepends: bin_prot,bin_prot.syntax Test mac_test Run$: flag(tests) Command: $mac_test WorkingDirectory: lib_test Executable example Path: lib_test MainIs: example.ml Build$: flag(tests) Install: false CompiledObject: best BuildDepends: bin_prot,bin_prot.syntax Document "bin_prot" Title: API reference for bin_prot Type: ocamlbuild (0.3) BuildTools+: ocamldoc XOCamlbuildPath: lib XOCamlbuildLibraries: bin_prot bin_prot-109.30.00/_tags000066400000000000000000000063641216015522300146660ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 291d2243dcbd22ef8cbed21bc7890e46) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse ".bzr": not_hygienic ".hg": -traverse ".hg": not_hygienic ".git": -traverse ".git": not_hygienic "_darcs": -traverse "_darcs": not_hygienic # Library bin_prot "lib/bin_prot.cmxs": use_bin_prot "lib/binable.cmx": for-pack(Bin_prot) "lib/nat0.cmx": for-pack(Bin_prot) "lib/common.cmx": for-pack(Bin_prot) "lib/unsafe_common.cmx": for-pack(Bin_prot) "lib/unsafe_write_c.cmx": for-pack(Bin_prot) "lib/unsafe_read_c.cmx": for-pack(Bin_prot) "lib/size.cmx": for-pack(Bin_prot) "lib/write_ml.cmx": for-pack(Bin_prot) "lib/read_ml.cmx": for-pack(Bin_prot) "lib/write_c.cmx": for-pack(Bin_prot) "lib/read_c.cmx": for-pack(Bin_prot) "lib/std.cmx": for-pack(Bin_prot) "lib/type_class.cmx": for-pack(Bin_prot) "lib/map_to_safe.cmx": for-pack(Bin_prot) "lib/utils.cmx": for-pack(Bin_prot) : use_libbin_prot_stubs : pkg_unix : pkg_bigarray "lib/common_stubs.c": pkg_unix "lib/common_stubs.c": pkg_bigarray "lib/write_stubs.c": pkg_unix "lib/write_stubs.c": pkg_bigarray "lib/read_stubs.c": pkg_unix "lib/read_stubs.c": pkg_bigarray # Library pa_bin_prot "syntax/pa_bin_prot.cmxs": use_pa_bin_prot : pkg_camlp4.quotations : pkg_camlp4.extend : pkg_type_conv # Executable test_runner : use_bin_prot : use_pa_bin_prot : pkg_oUnit : pkg_camlp4.quotations : pkg_camlp4.extend : pkg_type_conv : pkg_unix : pkg_bigarray : pkg_oUnit : custom # Executable mac_test : use_bin_prot : use_pa_bin_prot : pkg_camlp4.quotations : pkg_camlp4.extend : pkg_type_conv : pkg_unix : pkg_bigarray : custom # Executable example : use_bin_prot : use_pa_bin_prot : pkg_camlp4.quotations : pkg_camlp4.extend : pkg_type_conv : pkg_unix : pkg_bigarray : use_bin_prot : use_pa_bin_prot : pkg_camlp4.quotations : pkg_camlp4.extend : pkg_type_conv : pkg_unix : pkg_bigarray # OASIS_STOP :cpp :mlh : syntax_camlp4o,pkg_type_conv.syntax : syntax_camlp4o bin_prot-109.30.00/config/000077500000000000000000000000001216015522300151025ustar00rootroot00000000000000bin_prot-109.30.00/config/arch.sh000077500000000000000000000006531216015522300163620ustar00rootroot00000000000000#!/bin/sh set -e if [ $# -lt 1 ]; then echo "Usage: arch.sh OCAMLC" >&2 exit 2 fi OCAMLC="$1" if $OCAMLC -ccopt -E -c config/test.c | grep -q ARCH_SIXTYFOUR_IS_DEFINED; then arch_sixtyfour=true else arch_sixtyfour=false fi if [ -e setup.data ]; then sed '/^arch_sixtyfour=/d' setup.data > setup.data.new mv setup.data.new setup.data fi cat >> setup.data < /* Defined in */ #if defined(ARCH_SIXTYFOUR) "ARCH_SIXTYFOUR_IS_DEFINED" #endif bin_prot-109.30.00/configure000077500000000000000000000005541216015522300155500ustar00rootroot00000000000000#!/bin/sh # OASIS_START # DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7) set -e FST=true for i in "$@"; do if $FST; then set -- FST=false fi case $i in --*=*) ARG=${i%%=*} VAL=${i##*=} set -- "$@" "$ARG" "$VAL" ;; *) set -- "$@" "$i" ;; esac done ocaml setup.ml -configure "$@" # OASIS_STOP bin_prot-109.30.00/lib/000077500000000000000000000000001216015522300144035ustar00rootroot00000000000000bin_prot-109.30.00/lib/META000066400000000000000000000011741216015522300150570ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 96f5cee1c2c33d767dce9897987c7781) version = "109.30.00" description = "bin_prot - binary protocol generator" requires = "unix bigarray" archive(byte) = "bin_prot.cma" archive(byte, plugin) = "bin_prot.cma" archive(native) = "bin_prot.cmxa" archive(native, plugin) = "bin_prot.cmxs" exists_if = "bin_prot.cma" package "syntax" ( version = "109.30.00" description = "Syntax extension for binary protocol generator" requires = "camlp4 type_conv bin_prot" archive(syntax, preprocessor) = "pa_bin_prot.cma" archive(syntax, toploop) = "pa_bin_prot.cma" exists_if = "pa_bin_prot.cma" ) # OASIS_STOP bin_prot-109.30.00/lib/bin_prot.mlpack000066400000000000000000000003311216015522300174050ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 587ff1270b3446e9490aea8b3ff16a98) Binable Nat0 Common Unsafe_common Unsafe_write_c Unsafe_read_c Size Write_ml Read_ml Write_c Read_c Std Type_class Map_to_safe Utils # OASIS_STOP bin_prot-109.30.00/lib/bin_prot.odocl000066400000000000000000000003311216015522300172360ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 587ff1270b3446e9490aea8b3ff16a98) Binable Nat0 Common Unsafe_common Unsafe_write_c Unsafe_read_c Size Write_ml Read_ml Write_c Read_c Std Type_class Map_to_safe Utils # OASIS_STOP bin_prot-109.30.00/lib/binable.ml000066400000000000000000000030331216015522300163300ustar00rootroot00000000000000(* Binable: signatures defining generated functions for the binary protocol *) module type S = sig type t val bin_size_t : t Size.sizer val bin_write_t : t Map_to_safe.writer val bin_write_t_ : t Unsafe_write_c.writer val bin_read_t : t Read_ml.reader val bin_read_t_ : t Unsafe_read_c.reader val bin_read_t__ : (int -> t) Unsafe_read_c.reader val bin_writer_t : t Type_class.writer val bin_reader_t : t Type_class.reader val bin_t : t Type_class.t end module type S1 = sig type 'a t val bin_size_t : ('a, 'a t) Size.sizer1 val bin_write_t :('a, 'a t) Map_to_safe.writer1 val bin_write_t_ :('a, 'a t) Unsafe_write_c.writer1 val bin_read_t : ('a, 'a t) Map_to_safe.reader1 val bin_read_t_ : ('a, 'a t) Unsafe_read_c.reader1 val bin_read_t__ : ('a, int -> 'a t) Unsafe_read_c.reader1 val bin_writer_t : ('a, 'a t) Type_class.S1.writer val bin_reader_t : ('a, 'a t) Type_class.S1.reader val bin_t : ('a, 'a t) Type_class.S1.t end module type S2 = sig type ('a, 'b) t val bin_size_t : ('a, 'b, ('a, 'b) t) Size.sizer2 val bin_write_t :('a, 'b, ('a, 'b) t) Map_to_safe.writer2 val bin_write_t_ :('a, 'b, ('a, 'b) t) Unsafe_write_c.writer2 val bin_read_t : ('a, 'b, ('a, 'b) t) Map_to_safe.reader2 val bin_read_t_ : ('a, 'b, ('a, 'b) t) Unsafe_read_c.reader2 val bin_read_t__ : ('a, 'b, int -> ('a, 'b) t) Unsafe_read_c.reader2 val bin_writer_t : ('a, 'b, ('a, 'b) t) Type_class.S2.writer val bin_reader_t : ('a, 'b, ('a, 'b) t) Type_class.S2.reader val bin_t : ('a, 'b, ('a, 'b) t) Type_class.S2.t end bin_prot-109.30.00/lib/common.ml000066400000000000000000000140121216015522300162230ustar00rootroot00000000000000(* Common: common definitions used by binary protocol converters *) open Printf open Bigarray type pos = int (* Errors and exceptions *) exception Buffer_short exception No_variant_match module ReadError = struct (* Order of variants matters. It must jibe with read_stubs.c. *) type t = | Neg_int8 | Int_code | Int_overflow | Nat0_code | Nat0_overflow | Int32_code | Int64_code | Nativeint_code | Unit_code | Bool_code | Option_code | String_too_long | Variant_tag | Array_too_long | Hashtbl_too_long | Sum_tag of string | Variant of string | Poly_rec_bound of string | Variant_wrong_type of string | Silly_type of string | Empty_type of string let to_string = function | Neg_int8 -> "Neg_int8" | Int_code -> "Int_code" | Int_overflow -> "Int_overflow" | Nat0_code -> "Nat0_code" | Nat0_overflow -> "Nat0_overflow" | Int32_code -> "Int32_code" | Int64_code -> "Int64_code" | Nativeint_code -> "Nativeint_code" | Unit_code -> "Unit_code" | Bool_code -> "Bool_code" | Option_code -> "Option_code" | String_too_long -> "String_too_long" | Variant_tag -> "Variant_tag" | Array_too_long -> "Array_too_long" | Hashtbl_too_long -> "Hashtbl_too_long" | Sum_tag loc -> "Sum_tag / " ^ loc | Variant loc -> "Variant / " ^ loc | Poly_rec_bound loc -> "Poly_rec_bound / " ^ loc | Variant_wrong_type loc -> "Variant_wrong_type / " ^ loc | Silly_type loc -> "Silly_type / " ^ loc | Empty_type loc -> "Empty_type / " ^ loc end exception Read_error of ReadError.t * pos exception Read_exc of exn * pos exception Poly_rec_write of string exception Empty_type of string let raise_read_error err pos = raise (Read_error (err, pos)) let raise_read_exc exc pos = raise (Read_exc (exc, pos)) let raise_concurrent_modification loc = failwith (loc ^ ": concurrent modification") let array_bound_error () = invalid_arg "index out of bounds" (* Buffers *) type pos_ref = pos ref type buf = (char, int8_unsigned_elt, c_layout) Array1.t let create_buf n = Array1.create Bigarray.char c_layout n let check_pos (buf : buf) pos = if pos >= Array1.dim buf then raise Buffer_short let safe_get_pos buf pos_ref = let pos = !pos_ref in check_pos buf pos; pos let check_next (buf : buf) next = if next > Array1.dim buf then raise Buffer_short let get_opt_pos ~loc ~var = function | Some pos -> if pos < 0 then invalid_arg (sprintf "Bin_prot.Common.%s: %s < 0" loc var); pos | None -> 0 external unsafe_blit_buf : src_pos : int -> src : buf -> dst_pos : int -> dst : buf -> len : int -> unit = "bin_prot_blit_buf_stub" let blit_buf ?src_pos ~src ?dst_pos ~dst len = let loc = "blit_buf" in let src_pos = get_opt_pos ~loc ~var:"src_pos" src_pos in let dst_pos = get_opt_pos ~loc ~var:"dst_pos" dst_pos in if len < 0 then invalid_arg "Bin_prot.Common.blit_buf: len < 0" else if len = 0 then ( if src_pos > Array1.dim src then invalid_arg "Bin_prot.Common.blit_buf: src_pos > src_len"; if dst_pos > Array1.dim dst then invalid_arg "Bin_prot.Common.blit_buf: dst_pos > dst_len") else ( if src_pos + len > Array1.dim src then invalid_arg "Bin_prot.Common.blit_buf: src_pos + len > src_len" else if dst_pos + len > Array1.dim dst then invalid_arg "Bin_prot.Common.blit_buf: dst_pos + len > dst_len" else unsafe_blit_buf ~src_pos ~src ~dst_pos ~dst ~len) external unsafe_blit_string_buf : src_pos : int -> string -> dst_pos : int -> buf -> len : int -> unit = "bin_prot_blit_string_buf_stub" "noalloc" let blit_string_buf ?src_pos str ?dst_pos buf ~len = let loc = "blit_string_buf" in let src_pos = get_opt_pos ~loc ~var:"src_pos" src_pos in let dst_pos = get_opt_pos ~loc ~var:"dst_pos" dst_pos in if len < 0 then invalid_arg "Bin_prot.Common.blit_string_buf: len < 0" else if len = 0 then ( if src_pos > String.length str then invalid_arg "Bin_prot.Common.blit_string_buf: src_pos > str_len"; if dst_pos > Array1.dim buf then invalid_arg "Bin_prot.Common.blit_string_buf: src_pos > buf") else ( if src_pos + len > String.length str then invalid_arg "Bin_prot.Common.blit_string_buf: src_pos + len > str_len" else if dst_pos + len > Array1.dim buf then invalid_arg "Bin_prot.Common.blit_string_buf: src_pos + len > buf" else unsafe_blit_string_buf ~src_pos str ~dst_pos buf ~len) external unsafe_blit_buf_string : src_pos : int -> buf -> dst_pos : int -> string -> len : int -> unit = "bin_prot_blit_buf_string_stub" "noalloc" let blit_buf_string ?src_pos buf ?dst_pos str ~len = let loc = "blit_buf_string" in let src_pos = get_opt_pos ~loc ~var:"src_pos" src_pos in let dst_pos = get_opt_pos ~loc ~var:"dst_pos" dst_pos in if len < 0 then invalid_arg "Bin_prot.Common.blit_buf_string: len < 0" else if len = 0 then ( if src_pos > Array1.dim buf then invalid_arg "Bin_prot.Common.blit_buf_string: src_pos > buf_len"; if dst_pos > String.length str then invalid_arg "Bin_prot.Common.blit_buf_string: src_pos > str_len") else ( if src_pos + len > Array1.dim buf then invalid_arg "Bin_prot.Common.blit_buf_string: src_pos + len > buf_len" else if dst_pos + len > String.length str then invalid_arg "Bin_prot.Common.blit_buf_string: src_pos + len > str_len" else unsafe_blit_buf_string ~src_pos buf ~dst_pos str ~len) (* Miscellaneous *) let rec copy_htbl_list htbl = function | [] -> htbl | (k, v) :: rest -> Hashtbl.add htbl k v; copy_htbl_list htbl rest external variant_of_int : int -> [> ] = "%identity" (* Bigarrays *) type vec32 = (float, float32_elt, fortran_layout) Array1.t type vec64 = (float, float64_elt, fortran_layout) Array1.t type vec = vec64 type mat32 = (float, float32_elt, fortran_layout) Array2.t type mat64 = (float, float64_elt, fortran_layout) Array2.t type mat = mat64 (* Initialisation *) external init : unit -> unit = "bin_prot_common_init_stub" let () = Callback.register_exception "Bin_prot.Common.Buffer_short" Buffer_short; init () bin_prot-109.30.00/lib/common.mli000066400000000000000000000133671216015522300164100ustar00rootroot00000000000000(** Common definitions used by binary protocol converters *) open Bigarray (** {2 Buffers} *) (** Position within buffers *) type pos = int (** Reference to a position within buffers *) type pos_ref = pos ref (** Buffers *) type buf = (char, int8_unsigned_elt, c_layout) Array1.t val create_buf : int -> buf (** [create_buf n] creates a buffer of size [n]. *) val check_pos : buf -> pos -> unit (** [check_pos buf pos] @raise Buffer_short if position [pos] exceeds the length of buffer [buf]. *) val check_next : buf -> pos -> unit (** [check_next buf pos] @raise Buffer_short if the next position after [pos] exceeds the length of buffer [buf]. *) val safe_get_pos : buf -> pos_ref -> pos (** [safe_get_pos buf pos_ref] @return the position referenced by [pos_ref] within buffer [buf]. @raise Buffer_short if the position exceeds the length of the buffer. *) val blit_string_buf : ?src_pos : int -> string -> ?dst_pos : int -> buf -> len : int -> unit (** [blit_string_buf ?src_pos src ?dst_pos dst ~len] blits [len] bytes of the source string [src] starting at position [src_pos] to buffer [dst] starting at position [dst_pos]. @raise Invalid_argument if the designated ranges are invalid. *) val blit_buf_string : ?src_pos : int -> buf -> ?dst_pos : int -> string -> len : int -> unit (** [blit_buf_string ?src_pos src ?dst_pos dst ~len] blits [len] bytes of the source buffer [src] starting at position [src_pos] to string [dst] starting at position [dst_pos]. @raise Invalid_argument if the designated ranges are invalid. *) val blit_buf : ?src_pos : int -> src : buf -> ?dst_pos : int -> dst : buf -> int -> unit (** [blit_buf ?src_pos ~src ?dst_pos ~dst len] blits [len] bytes of the source buffer [src] starting at position [src_pos] to destination buffer [dst] starting at position [dst_pos]. @raise Invalid_argument if the designated ranges are invalid. *) (** {2 Errors and exceptions} *) exception Buffer_short (** Buffer too short for read/write operation *) exception No_variant_match (** Used internally for backtracking *) module ReadError : sig type t = | Neg_int8 (** Negative integer was positive or zero *) | Int_code (** Unknown integer code while reading integer *) | Int_overflow (** Overflow reading integer *) | Nat0_code (** Unknown integer code while reading natural number *) | Nat0_overflow (** Overflow reading natural number *) | Int32_code (** Unknown integer code while reading 32bit integer *) | Int64_code (** Unknown integer code while reading 64bit integer *) | Nativeint_code (** Unknown integer code while reading native integer *) | Unit_code (** Illegal unit value *) | Bool_code (** Illegal boolean value *) | Option_code (** Illegal option code *) | String_too_long (** String too long *) | Variant_tag (** Untagged integer encoding for variant tag *) | Array_too_long (** Array too long *) | Hashtbl_too_long (** Hashtable too long *) | Sum_tag of string (** Illegal sum tag for given type *) | Variant of string (** Illegal variant for given type *) | Poly_rec_bound of string (** Attempt to read data bound through polymorphic record fields *) | Variant_wrong_type of string (** Unexpected attempt to read variant with given non-variant type *) | Silly_type of string (** [Silly_type type_name] indicates unhandled but silly case where a type of the sort [type 'a type_name = 'a] is used with a polymorphic variant as type parameter and included in another polymorphic variant type. *) | Empty_type of string (** Attempt to read data that corresponds to an empty type. *) val to_string : t -> string (** [to_string err] @return string representation of read error [err]. *) end exception Read_error of ReadError.t * pos (** [ReadError (err, err_pos)] *) exception Read_exc of exn * pos (** [ReadExc (exn, err_pos)] *) exception Poly_rec_write of string (** [PolyRecWrite type] gets raised when the user attempts to write or estimate the size of a value of a type that is bound through a polymorphic record field in type definition [type]. *) exception Empty_type of string (** [EmptyType] gets raised when the user attempts to write or estimate the size of a value of an empty type, which would not make sense. *) val raise_read_error : ReadError.t -> pos -> 'a (** [raise_read_error err pos] *) val raise_read_exc : exn -> pos -> 'a (** [raise_read_exc exc pos] *) val raise_concurrent_modification : string -> 'a (** [raise_concurrent_modification loc] @raise Failure if a binary writer detects a concurrent change to the underlying data structure. *) val array_bound_error : unit -> 'a (** [array_bound_error ()] *) (** {2 Bigarrays} *) type vec32 = (float, float32_elt, fortran_layout) Array1.t type vec64 = (float, float64_elt, fortran_layout) Array1.t type vec = vec64 type mat32 = (float, float32_elt, fortran_layout) Array2.t type mat64 = (float, float64_elt, fortran_layout) Array2.t type mat = mat64 (** {2 Miscellaneous} *) val copy_htbl_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list -> ('a, 'b) Hashtbl.t (** [copy_htbl_list htbl lst] adds all [(key, value)] pairs in [lst] to hash table [htbl]. *) external variant_of_int : int -> [> ] = "%identity" (** {2 NOTE: unsafe functions!!!} *) external unsafe_blit_buf : src_pos : int -> src : buf -> dst_pos : int -> dst : buf -> len : int -> unit = "bin_prot_blit_buf_stub" external unsafe_blit_string_buf : src_pos : int -> string -> dst_pos : int -> buf -> len : int -> unit = "bin_prot_blit_string_buf_stub" "noalloc" external unsafe_blit_buf_string : src_pos : int -> buf -> dst_pos : int -> string -> len : int -> unit = "bin_prot_blit_buf_string_stub" "noalloc" bin_prot-109.30.00/lib/common_stubs.c000066400000000000000000000072201216015522300172600ustar00rootroot00000000000000/* Stubs for common binary protocol functions */ #include "common_stubs.h" value *v_bin_prot_exc_Buffer_short; CAMLprim value bin_prot_common_init_stub(value __unused v_unit) { v_bin_prot_exc_Buffer_short = caml_named_value("Bin_prot.Common.Buffer_short"); return Val_unit; } /* Utility definitions */ CAMLprim inline __pure value get_buf_ptr_stub(value v_buf, value v_pos) { char *sptr = Caml_ba_data_val(v_buf); char *eptr = sptr + Long_val(v_pos); return (value) eptr; } CAMLprim inline __attribute__ ((const)) value get_buf_pos_stub(value v_start, value v_cur) { return Val_long((char *) v_cur - (char *) v_start); } CAMLprim value get_safe_buf_pos_stub( value __unused v_buf, value v_start, value v_cur) { return get_buf_pos_stub(v_start, v_cur); } CAMLprim value shift_sptr_stub(char *sptr, value v_n) { return (value) (sptr + Long_val(v_n)); } CAMLprim value get_eptr_from_sptr_ptr(char **sptr_ptr, value v_pos) { return (value) (*sptr_ptr + Long_val(v_pos)); } CAMLprim __malloc char ** alloc_sptr_ptr_stub(value v_buf, value v_pos) { char **sptr_ptr = caml_stat_alloc(sizeof(char *)); *sptr_ptr = (char *) get_buf_ptr_stub(v_buf, v_pos); return sptr_ptr; } CAMLprim value dealloc_sptr_ptr_stub(value v_buf, char /*@only@*/ **sptr_ptr) { unsigned long pos = (*sptr_ptr) - (char *) Caml_ba_data_val(v_buf); free((char **) sptr_ptr); return Val_long(pos); } CAMLprim value set_sptr_ptr_stub(char **sptr_ptr, value v_buf, value v_pos) { *sptr_ptr = (char *) Caml_ba_data_val(v_buf) + Long_val(v_pos); return Val_unit; } CAMLprim __pure value get_sptr_ptr_stub(char **sptr_ptr, value v_buf) { return Val_long(*sptr_ptr - (char *) Caml_ba_data_val(v_buf)); } CAMLprim __pure value get_sptr_ptr_sptr_stub(char **sptr_ptr) { return (value) *sptr_ptr; } CAMLprim value set_sptr_ptr_sptr_stub(char **sptr_ptr, char *sptr) { *sptr_ptr = sptr; return Val_unit; } CAMLprim value get_ptr_string_stub(char *sptr, char *eptr) { unsigned long len = eptr - sptr; value v_str = caml_alloc_string((mlsize_t) len); memcpy(String_val(v_str), sptr, (size_t) len); return v_str; } /* Blitting strings to buffers */ static inline __pure char * get_buf(value v_buf, value v_pos) { return (char *) Caml_ba_data_val(v_buf) + Long_val(v_pos); } CAMLprim value bin_prot_blit_string_buf_stub( value v_src_pos, value v_str, value v_dst_pos, value v_buf, value v_len) { char *str = String_val(v_str) + Long_val(v_src_pos); char *buf = get_buf(v_buf, v_dst_pos); memcpy(buf, str, (size_t) Long_val(v_len)); return Val_unit; } CAMLprim value bin_prot_blit_buf_string_stub( value v_src_pos, value v_buf, value v_dst_pos, value v_str, value v_len) { char *buf = get_buf(v_buf, v_src_pos); char *str = String_val(v_str) + Long_val(v_dst_pos); memcpy(str, buf, (size_t) Long_val(v_len)); return Val_unit; } CAMLprim value bin_prot_blit_buf_stub( value v_src_pos, value v_src, value v_dst_pos, value v_dst, value v_len) { struct caml_ba_array *ba_src = Caml_ba_array_val(v_src); struct caml_ba_array *ba_dst = Caml_ba_array_val(v_dst); char *src = (char *) ba_src->data + Long_val(v_src_pos); char *dst = (char *) ba_dst->data + Long_val(v_dst_pos); size_t len = (size_t) Long_val(v_len); if ( unlikely(len > 65536) || unlikely(((ba_src->flags & CAML_BA_MAPPED_FILE) != 0)) || unlikely(((ba_dst->flags & CAML_BA_MAPPED_FILE) != 0)) ) /* use [memmove] rather than [memcpy] because src and dst may overlap */ { Begin_roots2(v_src, v_dst); caml_enter_blocking_section(); memmove(dst, src, len); caml_leave_blocking_section(); End_roots(); } else memmove(dst, src, len); return Val_unit; } bin_prot-109.30.00/lib/common_stubs.h000066400000000000000000000131371216015522300172710ustar00rootroot00000000000000/* Common binary protocol definitions */ #ifndef COMMON_STUBS_H #define COMMON_STUBS_H #define _BSD_SOURCE #include #include #include #include #include #include #include #include #include #include #include #ifdef ARCH_INT64_TYPE #include "int64_native.h" #else #include "int64_emul.h" #endif /* Endianness- and alignment-independent integer marshalling functions */ #define le8dec(x) (*x) #ifndef le16dec /* FreeBSD marshalling functions not available */ #ifdef OS_DARWIN /* Darwin platform */ #include #define le16dec(ptr) OSReadLittleInt16(ptr, 0) #define le32dec(ptr) OSReadLittleInt32(ptr, 0) #define le64dec(ptr) OSReadLittleInt64(ptr, 0) #define be16dec(ptr) OSReadBigInt16(ptr, 0) #define be32dec(ptr) OSReadBigInt32(ptr, 0) #define be64dec(ptr) OSReadBigInt64(ptr, 0) #define le16enc(ptr, n) OSWriteLittleInt16(ptr, 0, n) #define le32enc(ptr, n) OSWriteLittleInt32(ptr, 0, n) #define le64enc(ptr, n) OSWriteLittleInt64(ptr, 0, n) #define be16enc(ptr, n) OSWriteBigInt16(ptr, 0, n) #define be32enc(ptr, n) OSWriteBigInt32(ptr, 0, n) #define be64enc(ptr, n) OSWriteBigInt64(ptr, 0, n) #else /* Non-Darwin platform */ /* Emulate with memcpy and endianness conversion functions */ /* Define BSD conversion functions if undefined */ #ifndef le16toh /* Define portable byte swapping if undefined */ /* WARNING: will not work on mixed endian machines! */ /* WARNING: these functions must be defined by the system in the above case */ #ifndef bswap_16 #define bswap_16(value) \ (((uint16_t) ((value) & 0xff) << 8) | ((uint16_t) (value) >> 8)) #endif #ifndef bswap_32 #define bswap_32(value) \ (((uint32_t) bswap_16(((value) & 0xffff)) << 16) | \ (uint32_t) bswap_16(((value) >> 16))) #endif #ifndef bswap_64 #define bswap_64(value) \ (((uint64_t) bswap_32(((value) & 0xffffffff)) << 32) | \ (uint64_t) bswap_32(((value) >> 32))) #endif #if __BYTE_ORDER == __LITTLE_ENDIAN /* Little-endian architecture */ #define htobe16(x) bswap_16 (x) #define htole16(x) (x) #define be16toh(x) bswap_16 (x) #define le16toh(x) (x) #define htobe32(x) bswap_32 (x) #define htole32(x) (x) #define be32toh(x) bswap_32 (x) #define le32toh(x) (x) #define htobe64(x) bswap_64 (x) #define htole64(x) (x) #define be64toh(x) bswap_64 (x) #define le64toh(x) (x) #else /* Big-endian architecture */ #define htobe16(x) (x) #define htole16(x) bswap_16 (x) #define be16toh(x) (x) #define le16toh(x) bswap_16 (x) #define htobe32(x) (x) #define htole32(x) bswap_32 (x) #define be32toh(x) (x) #define le32toh(x) bswap_32 (x) #define htobe64(x) (x) #define htole64(x) bswap_64 (x) #define be64toh(x) (x) #define le64toh(x) bswap_64 (x) #endif /* byte order */ #endif /* BSD conversion functions */ #define le16dec(ptr) \ (__extension__ ({ uint16_t __n; memcpy(&__n, ptr, 2); le16toh(__n); })) #define le32dec(ptr) \ (__extension__ ({ uint32_t __n; memcpy(&__n, ptr, 4); le32toh(__n); })) #define le64dec(ptr) \ (__extension__ ({ uint64_t __n; memcpy(&__n, ptr, 8); le64toh(__n); })) #define be16dec(ptr) \ (__extension__ ({ uint16_t __n; memcpy(&__n, ptr, 2); be16toh(__n); })) #define be32dec(ptr) \ (__extension__ ({ uint32_t __n; memcpy(&__n, ptr, 4); be32toh(__n); })) #define be64dec(ptr) \ (__extension__ ({ uint64_t __n; memcpy(&__n, ptr, 8); be64toh(__n); })) #define le16enc(ptr, n) \ (__extension__ ({ uint16_t __n = htole16(n); memcpy(ptr, &__n, 2); })) #define le32enc(ptr, n) \ (__extension__ ({ uint32_t __n = htole32(n); memcpy(ptr, &__n, 4); })) #define le64enc(ptr, n) \ (__extension__ ({ uint64_t __n = htole64(n); memcpy(ptr, &__n, 8); })) #define be16enc(ptr, n) \ (__extension__ ({ uint16_t __n = htobe16(n); memcpy(ptr, &__n, 2); })) #define be32enc(ptr, n) \ (__extension__ ({ uint32_t __n = htobe32(n); memcpy(ptr, &__n, 4); })) #define be64enc(ptr, n) \ (__extension__ ({ uint64_t __n = htobe64(n); memcpy(ptr, &__n, 8); })) #endif /* OS_DARWIN */ #endif /* FreeBSD marshalling functions */ /* Bin-prot integer codes */ #define CODE_NEG_INT8 (char) -1 #define CODE_INT16 (char) -2 #define CODE_INT32 (char) -3 #define CODE_INT64 (char) -4 /* Buffer short exception */ extern value *v_bin_prot_exc_Buffer_short; /* Compiler pragmas and inlining */ /* Forget any previous definition of inlining, it may not be what we mean */ #ifdef inline # undef inline #endif /* The semantics of "inline" in C99 is not what we intend so just drop it */ #if defined(__STDC__) && __STDC__ && \ defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L # define inline #endif #if defined(__GNUC__) && __GNUC__ >= 3 # ifndef inline # define inline inline __attribute__ ((always_inline)) # endif # ifndef __pure # define __pure __attribute__ ((pure)) # endif # ifndef __const # define __const __attribute__ ((const)) # endif # ifndef __malloc # define __malloc __attribute__ ((malloc)) # endif # ifndef __unused # define __unused __attribute__ ((unused)) # endif # ifndef __likely # define likely(x) __builtin_expect (!!(x), 1) # endif # ifndef __unlikely # define unlikely(x) __builtin_expect (!!(x), 0) # endif #else /* Non-GNU compilers should always ignore "inline" no matter the C-standard */ # ifndef inline # define inline # endif # ifndef __pure # define __pure # endif # ifndef __const # define __const # endif # ifndef __malloc # define __malloc # endif # ifndef __unused # define __unused # endif # ifndef __likely # define likely(x) (x) # endif # ifndef __unlikely # define unlikely(x) (x) # endif #endif #endif /* COMMON_STUBS_H */ bin_prot-109.30.00/lib/int64_emul.h000066400000000000000000000122041216015522300165410ustar00rootroot00000000000000/* Software emulation of 64-bit integer arithmetic, for C compilers that do not support it. */ #ifndef CAML_INT64_EMUL_H #define CAML_INT64_EMUL_H #include #ifdef ARCH_BIG_ENDIAN #define I64_literal(hi,lo) { hi, lo } #else #define I64_literal(hi,lo) { lo, hi } #endif #define I64_split(x,hi,lo) (hi = (x).h, lo = (x).l) /* Unsigned comparison */ static int I64_ucompare(uint64 x, uint64 y) { if (x.h > y.h) return 1; if (x.h < y.h) return -1; if (x.l > y.l) return 1; if (x.l < y.l) return -1; return 0; } #define I64_ult(x, y) (I64_ucompare(x, y) < 0) /* Signed comparison */ static int I64_compare(int64 x, int64 y) { if ((int32)x.h > (int32)y.h) return 1; if ((int32)x.h < (int32)y.h) return -1; if (x.l > y.l) return 1; if (x.l < y.l) return -1; return 0; } /* Negation */ static int64 I64_neg(int64 x) { int64 res; res.l = -x.l; res.h = ~x.h; if (res.l == 0) res.h++; return res; } /* Addition */ static int64 I64_add(int64 x, int64 y) { int64 res; res.l = x.l + y.l; res.h = x.h + y.h; if (res.l < x.l) res.h++; return res; } /* Subtraction */ static int64 I64_sub(int64 x, int64 y) { int64 res; res.l = x.l - y.l; res.h = x.h - y.h; if (x.l < y.l) res.h--; return res; } /* Multiplication */ static int64 I64_mul(int64 x, int64 y) { int64 res; uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF); uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16); uint32 prod11 = (x.l >> 16) * (y.l >> 16); res.l = prod00; res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++; res.h += x.l * y.h + x.h * y.l; return res; } #define I64_is_zero(x) (((x).l | (x).h) == 0) #define I64_is_negative(x) ((int32) (x).h < 0) #define I64_is_min_int(x) ((x).l == 0 && (x).h == 0x80000000U) #define I64_is_minus_one(x) (((x).l & (x).h) == 0xFFFFFFFFU) /* Bitwise operations */ static int64 I64_and(int64 x, int64 y) { int64 res; res.l = x.l & y.l; res.h = x.h & y.h; return res; } static int64 I64_or(int64 x, int64 y) { int64 res; res.l = x.l | y.l; res.h = x.h | y.h; return res; } static int64 I64_xor(int64 x, int64 y) { int64 res; res.l = x.l ^ y.l; res.h = x.h ^ y.h; return res; } /* Shifts */ static int64 I64_lsl(int64 x, int s) { int64 res; s = s & 63; if (s == 0) return x; if (s < 32) { res.l = x.l << s; res.h = (x.h << s) | (x.l >> (32 - s)); } else { res.l = 0; res.h = x.l << (s - 32); } return res; } static int64 I64_lsr(int64 x, int s) { int64 res; s = s & 63; if (s == 0) return x; if (s < 32) { res.l = (x.l >> s) | (x.h << (32 - s)); res.h = x.h >> s; } else { res.l = x.h >> (s - 32); res.h = 0; } return res; } static int64 I64_asr(int64 x, int s) { int64 res; s = s & 63; if (s == 0) return x; if (s < 32) { res.l = (x.l >> s) | (x.h << (32 - s)); res.h = (int32) x.h >> s; } else { res.l = (int32) x.h >> (s - 32); res.h = (int32) x.h >> 31; } return res; } /* Division and modulus */ #define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 #define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 static void I64_udivmod(uint64 modulus, uint64 divisor, uint64 * quo, uint64 * mod) { int64 quotient, mask; int cmp; quotient.h = 0; quotient.l = 0; mask.h = 0; mask.l = 1; while ((int32) divisor.h >= 0) { cmp = I64_ucompare(divisor, modulus); I64_SHL1(divisor); I64_SHL1(mask); if (cmp >= 0) break; } while (mask.l | mask.h) { if (I64_ucompare(modulus, divisor) >= 0) { quotient.h |= mask.h; quotient.l |= mask.l; modulus = I64_sub(modulus, divisor); } I64_SHR1(mask); I64_SHR1(divisor); } *quo = quotient; *mod = modulus; } static int64 I64_div(int64 x, int64 y) { int64 q, r; int32 sign; sign = x.h ^ y.h; if ((int32) x.h < 0) x = I64_neg(x); if ((int32) y.h < 0) y = I64_neg(y); I64_udivmod(x, y, &q, &r); if (sign < 0) q = I64_neg(q); return q; } static int64 I64_mod(int64 x, int64 y) { int64 q, r; int32 sign; sign = x.h; if ((int32) x.h < 0) x = I64_neg(x); if ((int32) y.h < 0) y = I64_neg(y); I64_udivmod(x, y, &q, &r); if (sign < 0) r = I64_neg(r); return r; } /* Coercions */ static int64 I64_of_int32(int32 x) { int64 res; res.l = x; res.h = x >> 31; return res; } #define I64_to_int32(x) ((int32) (x).l) /* Note: we assume sizeof(intnat) = 4 here, which is true otherwise autoconfiguration would have selected native 64-bit integers */ #define I64_of_intnat I64_of_int32 #define I64_to_intnat I64_to_int32 static double I64_to_double(int64 x) { double res; int32 sign = x.h; if (sign < 0) x = I64_neg(x); res = ldexp((double) x.h, 32) + x.l; if (sign < 0) res = -res; return res; } static int64 I64_of_double(double f) { int64 res; double frac, integ; int neg; neg = (f < 0); f = fabs(f); frac = modf(ldexp(f, -32), &integ); res.h = (uint32) integ; res.l = (uint32) ldexp(frac, 32); if (neg) res = I64_neg(res); return res; } #endif /* CAML_INT64_EMUL_H */ bin_prot-109.30.00/lib/int64_native.h000066400000000000000000000025461216015522300170750ustar00rootroot00000000000000/* Wrapper macros around native 64-bit integer arithmetic, so that it has the same interface as the software emulation provided in int64_emul.h */ #ifndef CAML_INT64_NATIVE_H #define CAML_INT64_NATIVE_H #define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo)) #define I64_split(x,hi,lo) (hi = (uint32)((x)>>32), lo = (uint32)(x)) #define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) #define I64_ult(x,y) ((uint64)(x) < (uint64)(y)) #define I64_neg(x) (-(x)) #define I64_add(x,y) ((x) + (y)) #define I64_sub(x,y) ((x) - (y)) #define I64_mul(x,y) ((x) * (y)) #define I64_is_zero(x) ((x) == 0) #define I64_is_negative(x) ((x) < 0) #define I64_is_min_int(x) ((x) == ((int64)1 << 63)) #define I64_is_minus_one(x) ((x) == -1) #define I64_div(x,y) ((x) / (y)) #define I64_mod(x,y) ((x) % (y)) #define I64_udivmod(x,y,quo,rem) \ (*(rem) = (uint64)(x) % (uint64)(y), \ *(quo) = (uint64)(x) / (uint64)(y)) #define I64_and(x,y) ((x) & (y)) #define I64_or(x,y) ((x) | (y)) #define I64_xor(x,y) ((x) ^ (y)) #define I64_lsl(x,y) ((x) << (y)) #define I64_asr(x,y) ((x) >> (y)) #define I64_lsr(x,y) ((uint64)(x) >> (y)) #define I64_to_intnat(x) ((intnat) (x)) #define I64_of_intnat(x) ((intnat) (x)) #define I64_to_int32(x) ((int32) (x)) #define I64_of_int32(x) ((int64) (x)) #define I64_to_double(x) ((double)(x)) #define I64_of_double(x) ((int64)(x)) #endif /* CAML_INT64_NATIVE_H */ bin_prot-109.30.00/lib/int_codes.mlh000066400000000000000000000002201216015522300170460ustar00rootroot00000000000000(** Int_codes: integer codes used by the binary protocol *) let code_neg_int8 = -1 let code_int16 = -2 let code_int32 = -3 let code_int64 = -4 bin_prot-109.30.00/lib/libbin_prot_stubs.clib000066400000000000000000000001761216015522300207650ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 3bed0d99959dc0a5727c4f947e9b24d4) common_stubs.o write_stubs.o read_stubs.o # OASIS_STOP bin_prot-109.30.00/lib/map_to_safe.ml000066400000000000000000000010061216015522300172070ustar00rootroot00000000000000type 'a reader = 'a Read_ml.reader type ('a, 'b) reader1 = 'a Unsafe_read_c.reader -> 'b Read_ml.reader type ('a, 'b, 'c) reader2 = 'a Unsafe_read_c.reader -> ('b, 'c) reader1 type ('a, 'b, 'c, 'd) reader3 = 'a Unsafe_read_c.reader -> ('b, 'c, 'd) reader2 type 'a writer = 'a Write_ml.writer type ('a, 'b) writer1 = 'a Unsafe_write_c.writer -> 'b Write_ml.writer type ('a, 'b, 'c) writer2 = 'a Unsafe_write_c.writer -> ('b, 'c) writer1 type ('a, 'b, 'c, 'd) writer3 = 'a Unsafe_write_c.writer -> ('b, 'c, 'd) writer2 bin_prot-109.30.00/lib/nat0.ml000066400000000000000000000002701216015522300155760ustar00rootroot00000000000000(* Nat0: natural numbers (including zero) *) type t = int let of_int n = if n < 0 then failwith "Bin_prot.Nat0.of_int: n < 0"; n external unsafe_of_int : int -> t = "%identity" bin_prot-109.30.00/lib/nat0.mli000066400000000000000000000003601216015522300157470ustar00rootroot00000000000000(** Nat0: natural numbers (including zero) *) type t = private int val of_int : int -> t (** [of_int n] converts integer [n] to a natural number. @raise Failure if [n] is negative. *) external unsafe_of_int : int -> t = "%identity" bin_prot-109.30.00/lib/read_c.ml000066400000000000000000000105121216015522300161510ustar00rootroot00000000000000(* Read_c: wrapping unsafe C-style readers to safe ML-style ones. *) open Common open Unsafe_common open Unsafe_read_c let handle_error buf sptr_ptr read_err = let err_pos = dealloc_sptr_ptr buf sptr_ptr in let err_pos = match read_err with | ReadError.Variant _ -> err_pos - 4 | _ -> err_pos in raise_read_error read_err err_pos let handle_exc buf sptr_ptr exc = ignore (dealloc_sptr_ptr buf sptr_ptr); raise exc let at_end buf sptr_ptr pos_ref el = let pos = dealloc_sptr_ptr buf sptr_ptr in pos_ref := pos; el let make read_c buf ~pos_ref = let sptr_ptr, eptr = get_read_init buf ~pos_ref in let el = try read_c sptr_ptr eptr with | Error read_err -> handle_error buf sptr_ptr read_err | exc -> handle_exc buf sptr_ptr exc in at_end buf sptr_ptr pos_ref el let unmake read_ml buf sptr_ptr _eptr = let start_pos = get_sptr_ptr sptr_ptr buf in let pos_ref = ref start_pos in let el = read_ml buf ~pos_ref in set_sptr_ptr sptr_ptr buf ~pos:!pos_ref; el let make1 read_c read_ml_el buf ~pos_ref = let sptr_ptr, eptr = get_read_init buf ~pos_ref in let read_c_el = unmake read_ml_el buf in let el = try read_c read_c_el sptr_ptr eptr with | Error read_err -> handle_error buf sptr_ptr read_err | exc -> handle_exc buf sptr_ptr exc in at_end buf sptr_ptr pos_ref el let make2 read_c read_ml_el1 read_ml_el2 buf ~pos_ref = let sptr_ptr, eptr = get_read_init buf ~pos_ref in let read_c_el1 = unmake read_ml_el1 buf in let read_c_el2 = unmake read_ml_el2 buf in let el = try read_c read_c_el1 read_c_el2 sptr_ptr eptr with | Error read_err -> handle_error buf sptr_ptr read_err | exc -> handle_exc buf sptr_ptr exc in at_end buf sptr_ptr pos_ref el let make3 read_c read_ml_el1 read_ml_el2 read_ml_el3 buf ~pos_ref = let sptr_ptr, eptr = get_read_init buf ~pos_ref in let read_c_el1 = unmake read_ml_el1 buf in let read_c_el2 = unmake read_ml_el2 buf in let read_c_el3 = unmake read_ml_el3 buf in let el = try read_c read_c_el1 read_c_el2 read_c_el3 sptr_ptr eptr with | Error read_err -> handle_error buf sptr_ptr read_err | exc -> handle_exc buf sptr_ptr exc in at_end buf sptr_ptr pos_ref el let bin_read_unit = make Unsafe_read_c.bin_read_unit let bin_read_bool = make Unsafe_read_c.bin_read_bool let bin_read_string = make Unsafe_read_c.bin_read_string let bin_read_char = make Unsafe_read_c.bin_read_char let bin_read_int = make Unsafe_read_c.bin_read_int let bin_read_float = make Unsafe_read_c.bin_read_float let bin_read_int32 = make Unsafe_read_c.bin_read_int32 let bin_read_int64 = make Unsafe_read_c.bin_read_int64 let bin_read_nativeint = make Unsafe_read_c.bin_read_nativeint let bin_read_nat0 = make Unsafe_read_c.bin_read_nat0 let bin_read_ref mlw = make1 Unsafe_read_c.bin_read_ref mlw let bin_read_lazy mlw = make1 Unsafe_read_c.bin_read_lazy mlw let bin_read_option mlw = make1 Unsafe_read_c.bin_read_option mlw let bin_read_pair mlw = make2 Unsafe_read_c.bin_read_pair mlw let bin_read_triple mlw = make3 Unsafe_read_c.bin_read_triple mlw let bin_read_list mlw = make1 Unsafe_read_c.bin_read_list mlw let bin_read_array mlw = make1 Unsafe_read_c.bin_read_array mlw let bin_read_hashtbl mlw = make2 Unsafe_read_c.bin_read_hashtbl mlw let bin_read_float32_vec = make Unsafe_read_c.bin_read_float32_vec let bin_read_float64_vec = make Unsafe_read_c.bin_read_float64_vec let bin_read_vec = make Unsafe_read_c.bin_read_vec let bin_read_float32_mat = make Unsafe_read_c.bin_read_float32_mat let bin_read_float64_mat = make Unsafe_read_c.bin_read_float64_mat let bin_read_mat = make Unsafe_read_c.bin_read_mat let bin_read_bigstring = make Unsafe_read_c.bin_read_bigstring let bin_read_float_array = make Unsafe_read_c.bin_read_float_array let bin_read_variant_int el = make Unsafe_read_c.bin_read_variant_int el let bin_read_variant_tag el = make Unsafe_read_c.bin_read_variant_tag el let bin_read_int_64bit = make Unsafe_read_c.bin_read_int_64bit let bin_read_int64_bits = make Unsafe_read_c.bin_read_int64_bits let bin_read_network16_int = make Unsafe_read_c.bin_read_network16_int let bin_read_network32_int = make Unsafe_read_c.bin_read_network32_int let bin_read_network32_int32 = make Unsafe_read_c.bin_read_network32_int32 let bin_read_network64_int = make Unsafe_read_c.bin_read_network64_int let bin_read_network64_int64 = make Unsafe_read_c.bin_read_network64_int64 bin_prot-109.30.00/lib/read_c.mli000066400000000000000000000070511216015522300163260ustar00rootroot00000000000000(** Wrapping unsafe C-style readers to safe ML-style ones. *) open Common open Unsafe_common open Read_ml (** {2 Generic functions for easy creation of wrappers} *) val make : 'a Unsafe_read_c.reader -> 'a Read_ml.reader (** [make c_reader] takes an unsafe C-style reader [c_reader]. @return a safe ML-style reader. *) val make1 : ('a, 'b) Unsafe_read_c.reader1 -> ('a, 'b) Read_ml.reader1 (** [make1 mk_c_reader ml_el_reader] takes a higher-order C-style reader [mk_c_reader] and an ML-reader [ml_el_reader] that operates on the same type as the argument of the C-style reader. @return ML-style reader for the higher-order type. *) val make2 : ('a, 'b, 'c) Unsafe_read_c.reader2 -> ('a, 'b, 'c) Read_ml.reader2 (** [make2 mk_c_reader ml_el1_reader ml_el2_reader] like {!make1} but operates on unsafe C-style write functions for types with two type parameters. *) val make3 : ('a, 'b, 'c, 'd) Unsafe_read_c.reader3 -> ('a, 'b, 'c, 'd) Read_ml.reader3 (** [make3 mk_c_reader ml_el1_reader ml_el2_reader ml_el3_reader] like {!make1} but operates on unsafe C-style write functions for types with three type parameters. *) val unmake : 'b Read_ml.reader -> buf -> 'b Unsafe_read_c.reader (** [unmake ml_reader buf] takes an ML-style reader [ml_reader] and a buffer. This function can be used to wrap higher-order type conversion functions and, together with {!Unsafe_common.get_sptr_ptr}, {Unsafe_common.!set_sptr_ptr} and {!handle_error}, is used in e.g. {!make1}, {!make2} and {!make3} for that purpose. @return an unsafe C-style reader. *) val handle_error : buf -> sptr_ptr -> ReadError.t -> 'a (** [handle_error buf sptr_ptr err] deallocates [sptr_ptr] for buffer [buf]. @raise ReadError with the appropriate location information and [err] then. *) val handle_exc : buf -> sptr_ptr -> exn -> 'a (** [handle_exc buf sptr_ptr exc] deallocates [sptr_ptr] for buffer [buf]. raise exc then. *) val at_end : buf -> sptr_ptr -> pos_ref -> 'a -> 'a (** [at_end buf sptr_ptr pos_ref el] deallocates [sptr_ptr] for buffer [buf], sets [pos_ref] to the new position, then returns [el]. *) (** {2 Unsafe C-style readers for basic types wrapped as ML-style readers} *) val bin_read_unit : unit reader val bin_read_bool : bool reader val bin_read_string : string reader val bin_read_char : char reader val bin_read_int : int reader val bin_read_nat0 : Nat0.t reader val bin_read_float : float reader val bin_read_int32 : int32 reader val bin_read_int64 : int64 reader val bin_read_nativeint : nativeint reader val bin_read_ref : ('a, 'a ref) reader1 val bin_read_lazy : ('a, 'a lazy_t) reader1 val bin_read_option : ('a, 'a option) reader1 val bin_read_pair : ('a, 'b, 'a * 'b) reader2 val bin_read_triple : ('a, 'b, 'c, 'a * 'b * 'c) reader3 val bin_read_list : ('a, 'a list) reader1 val bin_read_array : ('a, 'a array) reader1 val bin_read_hashtbl : ('a, 'b, ('a, 'b) Hashtbl.t) reader2 val bin_read_float32_vec : vec32 reader val bin_read_float64_vec : vec64 reader val bin_read_vec : vec reader val bin_read_float32_mat : mat32 reader val bin_read_float64_mat : mat64 reader val bin_read_mat : mat reader val bin_read_bigstring : buf reader val bin_read_float_array : float array reader val bin_read_variant_int : int reader val bin_read_variant_tag : [> ] reader val bin_read_int_64bit : int reader val bin_read_int64_bits : int64 reader val bin_read_network16_int : int reader val bin_read_network32_int : int reader val bin_read_network32_int32 : int32 reader val bin_read_network64_int : int reader val bin_read_network64_int64 : int64 reader bin_prot-109.30.00/lib/read_ml.ml000066400000000000000000000416231216015522300163460ustar00rootroot00000000000000(* Read_ml: reading values from the binary protocol using (mostly) OCaml. *) #include "int_codes.mlh" open Common external init : unit -> unit = "bin_prot_read_ml_init_stub" let () = let read_error = Read_error (ReadError.Neg_int8, 0) in Callback.register_exception "Bin_prot.Common.Read_error" read_error; init () type 'a reader = buf -> pos_ref : pos_ref -> 'a type ('a, 'b) reader1 = 'a reader -> 'b reader type ('a, 'b, 'c) reader2 = 'a reader -> ('b, 'c) reader1 type ('a, 'b, 'c, 'd) reader3 = 'a reader -> ('b, 'c, 'd) reader2 let rewrite_c_error f buf ~pos_ref = try f buf ~pos_ref with Unsafe_read_c.Error read_err -> raise_read_error read_err !pos_ref let bin_read_unit (buf : buf) ~pos_ref = let pos = safe_get_pos buf pos_ref in if buf.{pos} = '\000' then pos_ref := pos + 1 else raise_read_error ReadError.Unit_code pos let bin_read_bool (buf : buf) ~pos_ref = let pos = safe_get_pos buf pos_ref in match buf.{pos} with | '\000' -> pos_ref := pos + 1; false | '\001' -> pos_ref := pos + 1; true | _ -> raise_read_error ReadError.Bool_code pos let get_signed_code (buf : buf) i = let c = Char.code buf.{i} in if c >= 128 then c - 256 else c let safe_bin_read_neg_int8 (buf : buf) ~pos_ref = let pos = safe_get_pos buf pos_ref in let n = get_signed_code buf pos in if n >= 0 then raise_read_error ReadError.Neg_int8 (pos - 1); pos_ref := pos + 1; n let do_bin_read_int16 (buf : buf) pos = let n = Char.code buf.{pos} in n + get_signed_code buf (pos + 1) lsl 8 let safe_bin_read_int16 buf ~pos_ref = let pos = !pos_ref in let next = pos + 2 in check_next buf next; pos_ref := next; (* Can be above next line (no errors possible with 16bit). This should improve the generated code. *) do_bin_read_int16 buf pos let check_overflow ~last ~pos = (* NOTE: OCaml integers are ordinary machine integers shifted to the left to gain one bit for tagging purposes (this bottommost bit is set for integers and unset for structured blocks). Negative numbers are handled the same way, and they are, as usual, in two-complement representation. Therefore the topmost byte in the memory representation of the OCaml-integer has lost one bit, limiting the range of positive integers, whose topmost bit must always be unset, from 0x00 to 0x3f instead of from 0x00 to 0x7f. For negative integers this means that the topmost byte, whose topmost bit is always set in that case, does not range from 0xff down to 0x80, but only from 0xff to 0xc0 (note the reversal of the direction due to two-complement representation!). Thus any topmost byte greater than 0x3f and lower than 0xc0 is illegal. *) if last > 0x3f && last < 0xc0 then raise_read_error ReadError.Int_overflow (pos - 1) let do_bin_read_int32 (buf : buf) pos = #ifdef ARCH_SIXTYFOUR let last = get_signed_code buf (pos + 3) in #else let last = Char.code buf.{pos + 3} in check_overflow ~last ~pos; #endif let n = last lsl 24 in let n = n + Char.code buf.{pos + 2} lsl 16 in let n = n + Char.code buf.{pos + 1} lsl 8 in n + Char.code buf.{pos} let safe_bin_read_int32 buf ~pos_ref = let pos = !pos_ref in let next = pos + 4 in check_next buf next; let n = do_bin_read_int32 buf pos in pos_ref := next; n #ifdef ARCH_SIXTYFOUR let do_bin_read_int64 (buf : buf) pos = let last = Char.code buf.{pos + 7} in check_overflow ~last ~pos; let n = last lsl 56 in let n = n + Char.code buf.{pos + 6} lsl 48 in let n = n + Char.code buf.{pos + 5} lsl 40 in let n = n + Char.code buf.{pos + 4} lsl 32 in let n = n + Char.code buf.{pos + 3} lsl 24 in let n = n + Char.code buf.{pos + 2} lsl 16 in let n = n + Char.code buf.{pos + 1} lsl 8 in n + Char.code buf.{pos} let safe_bin_read_int64 buf ~pos_ref = let pos = !pos_ref in let next = pos + 8 in check_next buf next; let n = do_bin_read_int64 buf pos in pos_ref := next; n #endif let do_bin_read_nat0_16 (buf : buf) pos = let n = Char.code buf.{pos} in n + Char.code buf.{pos + 1} lsl 8 let safe_bin_read_nat0_16 buf ~pos_ref = let pos = !pos_ref in let next = pos + 2 in check_next buf next; pos_ref := next; (* Can be above next line (no errors possible with 16bit). This should improve the generated code. *) let n = do_bin_read_nat0_16 buf pos in Nat0.unsafe_of_int n let check_pos_overflow ~last ~pos = (* NOTE: see {!check_overflow} for meaning of constant *) if last > 0x3f then raise_read_error ReadError.Nat0_overflow (pos - 1) let do_bin_read_nat0_32 (buf : buf) pos = let last = Char.code buf.{pos + 3} in #ifndef ARCH_SIXTYFOUR check_pos_overflow ~last ~pos; #endif let n = last lsl 24 in let n = n + Char.code buf.{pos + 2} lsl 16 in let n = n + Char.code buf.{pos + 1} lsl 8 in n + Char.code buf.{pos} let safe_bin_read_nat0_32 buf ~pos_ref = let pos = !pos_ref in let next = pos + 4 in check_next buf next; let n = do_bin_read_nat0_32 buf pos in pos_ref := next; Nat0.unsafe_of_int n #ifdef ARCH_SIXTYFOUR let do_bin_read_nat0_64 (buf : buf) pos = let last = Char.code buf.{pos + 7} in check_pos_overflow ~last ~pos; let n = last lsl 56 in let n = n + Char.code buf.{pos + 6} lsl 48 in let n = n + Char.code buf.{pos + 5} lsl 40 in let n = n + Char.code buf.{pos + 4} lsl 32 in let n = n + Char.code buf.{pos + 3} lsl 24 in let n = n + Char.code buf.{pos + 2} lsl 16 in let n = n + Char.code buf.{pos + 1} lsl 8 in n + Char.code buf.{pos} let safe_bin_read_nat0_64 buf ~pos_ref = let pos = !pos_ref in let next = pos + 8 in check_next buf next; let n = do_bin_read_nat0_64 buf pos in pos_ref := next; Nat0.unsafe_of_int n #endif let bin_read_nat0 buf ~pos_ref = let pos = safe_get_pos buf pos_ref in let code = get_signed_code buf pos in pos_ref := pos + 1; if code >= 0 then Nat0.unsafe_of_int code else if code = code_int16 then safe_bin_read_nat0_16 buf ~pos_ref else if code = code_int32 then safe_bin_read_nat0_32 buf ~pos_ref #ifdef ARCH_SIXTYFOUR else if code = code_int64 then safe_bin_read_nat0_64 buf ~pos_ref #endif else ( pos_ref := pos; raise_read_error ReadError.Nat0_code pos) let bin_read_string buf ~pos_ref = let start_pos = !pos_ref in let len = (bin_read_nat0 buf ~pos_ref :> int) in if len > Sys.max_string_length then raise_read_error ReadError.String_too_long start_pos; let pos = !pos_ref in let next = pos + len in check_next buf next; pos_ref := next; let str = String.create len in unsafe_blit_buf_string ~src_pos:pos buf ~dst_pos:0 str ~len; str let bin_read_char (buf : buf) ~pos_ref = let pos = safe_get_pos buf pos_ref in pos_ref := pos + 1; buf.{pos} let bin_read_int buf ~pos_ref = let pos = safe_get_pos buf pos_ref in let code = get_signed_code buf pos in pos_ref := pos + 1; if code >= 0 then code else if code = code_int16 then safe_bin_read_int16 buf ~pos_ref else if code = code_neg_int8 then safe_bin_read_neg_int8 buf ~pos_ref else if code = code_int32 then safe_bin_read_int32 buf ~pos_ref #ifdef ARCH_SIXTYFOUR else if code = code_int64 then safe_bin_read_int64 buf ~pos_ref #endif else ( pos_ref := pos; raise_read_error ReadError.Int_code pos) external bin_read_float : buf -> pos_ref : int ref -> float = "ml_read_float_stub" let bin_read_float buf ~pos_ref = rewrite_c_error bin_read_float buf ~pos_ref let read_int32_aux buf ~pos_ref = #ifdef ARCH_SIXTYFOUR let n = safe_bin_read_int32 buf ~pos_ref in Int32.of_int n #else let pos = !pos_ref in let next = pos + 4 in check_next buf next; pos_ref := next; let n = Char.code buf.{pos} in let n = n + Char.code buf.{pos + 1} lsl 8 in let n = n + Char.code buf.{pos + 2} lsl 16 in let n32 = Int32.of_int (Char.code buf.{pos + 3}) in Int32.add (Int32.of_int n) (Int32.shift_left n32 24) #endif let bin_read_int32 buf ~pos_ref = let pos = safe_get_pos buf pos_ref in let code = get_signed_code buf pos in pos_ref := pos + 1; if code >= 0 then Int32.of_int code else if code = code_int16 then let n = safe_bin_read_int16 buf ~pos_ref in Int32.of_int n else if code = code_neg_int8 then let n = safe_bin_read_neg_int8 buf ~pos_ref in Int32.of_int n else if code = code_int32 then read_int32_aux buf ~pos_ref else ( pos_ref := pos; raise_read_error ReadError.Int32_code pos) let read_int64_aux buf ~pos_ref = let pos = !pos_ref in let next = pos + 8 in check_next buf next; pos_ref := next; let n = Char.code buf.{pos} in let n = n + Char.code buf.{pos + 1} lsl 8 in let n = n + Char.code buf.{pos + 2} lsl 16 in #ifdef ARCH_SIXTYFOUR let n = n + Char.code buf.{pos + 3} lsl 24 in let n = n + Char.code buf.{pos + 4} lsl 32 in let n = n + Char.code buf.{pos + 5} lsl 40 in let n = n + Char.code buf.{pos + 6} lsl 48 in let n64 = Int64.of_int (Char.code buf.{pos + 7}) in Int64.add (Int64.of_int n) (Int64.shift_left n64 56) #else let n64 = Int64.of_int (Char.code buf.{pos + 3}) in let n64_1 = Int64.add (Int64.of_int n) (Int64.shift_left n64 24) in let n = Char.code buf.{pos + 4} in let n = n + Char.code buf.{pos + 5} lsl 8 in let n = n + Char.code buf.{pos + 6} lsl 16 in let n64 = Int64.of_int (Char.code buf.{pos + 7}) in let n64_2 = Int64.add (Int64.of_int n) (Int64.shift_left n64 24) in Int64.add n64_1 (Int64.shift_left n64_2 32) #endif let bin_read_int64 buf ~pos_ref = let pos = safe_get_pos buf pos_ref in let code = get_signed_code buf pos in pos_ref := pos + 1; if code >= 0 then Int64.of_int code else if code = code_int16 then let n = safe_bin_read_int16 buf ~pos_ref in Int64.of_int n else if code = code_neg_int8 then let n = safe_bin_read_neg_int8 buf ~pos_ref in Int64.of_int n else if code = code_int32 then let n = read_int32_aux buf ~pos_ref in Int64.of_int32 n else if code = code_int64 then read_int64_aux buf ~pos_ref else ( pos_ref := pos; raise_read_error ReadError.Int64_code pos) let bin_read_nativeint buf ~pos_ref = let pos = safe_get_pos buf pos_ref in let code = get_signed_code buf pos in pos_ref := pos + 1; if code >= 0 then Nativeint.of_int code else if code = code_int16 then let n = safe_bin_read_int16 buf ~pos_ref in Nativeint.of_int n else if code = code_neg_int8 then let n = safe_bin_read_neg_int8 buf ~pos_ref in Nativeint.of_int n else if code = code_int32 then let n = read_int32_aux buf ~pos_ref in Nativeint.of_int32 n #ifdef ARCH_SIXTYFOUR else if code = code_int64 then let n = read_int64_aux buf ~pos_ref in Int64.to_nativeint n #endif else ( pos_ref := pos; raise_read_error ReadError.Nativeint_code pos) let bin_read_ref bin_read_el buf ~pos_ref = let el = bin_read_el buf ~pos_ref in ref el let bin_read_lazy bin_read_el buf ~pos_ref = let el = bin_read_el buf ~pos_ref in Lazy.lazy_from_val el let bin_read_option bin_read_el buf ~pos_ref = let pos = safe_get_pos buf pos_ref in match buf.{pos} with | '\000' -> pos_ref := pos + 1; None | '\001' -> pos_ref := pos + 1; let el = bin_read_el buf ~pos_ref in Some el | _ -> raise_read_error ReadError.Option_code pos let bin_read_pair bin_read_a bin_read_b buf ~pos_ref = let a = bin_read_a buf ~pos_ref in let b = bin_read_b buf ~pos_ref in a, b let bin_read_triple bin_read_a bin_read_b bin_read_c buf ~pos_ref = let a = bin_read_a buf ~pos_ref in let b = bin_read_b buf ~pos_ref in let c = bin_read_c buf ~pos_ref in a, b, c let bin_read_n_rev_list bin_read_el buf ~pos_ref len = let rec loop n acc = if n = 0 then acc else loop (n - 1) (bin_read_el buf ~pos_ref :: acc) in loop len [] let bin_read_list bin_read_el buf ~pos_ref = let len = (bin_read_nat0 buf ~pos_ref :> int) in let rev_lst = bin_read_n_rev_list bin_read_el buf ~pos_ref len in List.rev rev_lst #ifndef ARCH_SIXTYFOUR let dummy_float_buf = create_buf 8 let () = ignore (Write_ml.bin_write_float dummy_float_buf ~pos:0 3.1) let max_array_length_2 = Sys.max_array_length / 2 #endif let bin_read_array bin_read_el buf ~pos_ref = let start_pos = !pos_ref in let len = (bin_read_nat0 buf ~pos_ref :> int) in if len = 0 then [||] else ( #ifdef ARCH_SIXTYFOUR if len > Sys.max_array_length then raise_read_error ReadError.Array_too_long start_pos; #else if len > max_array_length_2 then ( let maybe_float = try let el = bin_read_el dummy_float_buf ~pos_ref:(ref 0) in Some el with _ -> None in match maybe_float with | None -> if len > Sys.max_array_length then raise_read_error ReadError.Array_too_long start_pos | Some el -> if Obj.tag (Obj.repr el) = Obj.double_tag || len > Sys.max_array_length then raise_read_error ReadError.Array_too_long start_pos ); #endif let first = bin_read_el buf ~pos_ref in let res = Array.create len first in for i = 1 to len - 1 do let el = bin_read_el buf ~pos_ref in Array.unsafe_set res i el done; res) let bin_read_hashtbl bin_read_key bin_read_val buf ~pos_ref = let len = (bin_read_nat0 buf ~pos_ref :> int) in let htbl = Hashtbl.create len in let read_kv_pair = bin_read_pair bin_read_key bin_read_val in let els = bin_read_n_rev_list read_kv_pair buf ~pos_ref len in copy_htbl_list htbl els external bin_read_float32_vec : buf -> pos_ref : pos_ref -> vec32 = "ml_read_float32_vec_stub" let bin_read_float32_vec buf ~pos_ref = rewrite_c_error bin_read_float32_vec buf ~pos_ref external bin_read_float64_vec : buf -> pos_ref : pos_ref -> vec64 = "ml_read_float64_vec_stub" let bin_read_float64_vec buf ~pos_ref = rewrite_c_error bin_read_float64_vec buf ~pos_ref external bin_read_vec : buf -> pos_ref : pos_ref -> vec = "ml_read_float64_vec_stub" let bin_read_vec buf ~pos_ref = rewrite_c_error bin_read_vec buf ~pos_ref external bin_read_float32_mat : buf -> pos_ref : pos_ref -> mat32 = "ml_read_float32_mat_stub" let bin_read_float32_mat buf ~pos_ref = rewrite_c_error bin_read_float32_mat buf ~pos_ref external bin_read_float64_mat : buf -> pos_ref : pos_ref -> mat64 = "ml_read_float64_mat_stub" let bin_read_float64_mat buf ~pos_ref = rewrite_c_error bin_read_float64_mat buf ~pos_ref external bin_read_mat : buf -> pos_ref : pos_ref -> mat = "ml_read_float64_mat_stub" let bin_read_mat buf ~pos_ref = rewrite_c_error bin_read_mat buf ~pos_ref external bin_read_bigstring : buf -> pos_ref : pos_ref -> buf = "ml_read_bigstring_stub" let bin_read_bigstring buf ~pos_ref = rewrite_c_error bin_read_bigstring buf ~pos_ref external bin_read_float_array : buf -> pos_ref : pos_ref -> float array = "ml_read_float_array_stub" let bin_read_float_array buf ~pos_ref = rewrite_c_error bin_read_float_array buf ~pos_ref external bin_read_variant_int : buf -> pos_ref : pos_ref -> int = "ml_read_variant_tag_stub" let bin_read_variant_int buf ~pos_ref = rewrite_c_error bin_read_variant_int buf ~pos_ref external bin_read_variant_tag : buf -> pos_ref : pos_ref -> [> ] = "ml_read_variant_tag_stub" let bin_read_variant_tag buf ~pos_ref = rewrite_c_error bin_read_variant_tag buf ~pos_ref external bin_read_int_8bit : buf -> pos_ref : pos_ref -> int = "ml_read_char_stub" let bin_read_int_8bit buf ~pos_ref = rewrite_c_error bin_read_int_8bit buf ~pos_ref external bin_read_int_16bit : buf -> pos_ref : pos_ref -> int = "ml_read_int_16bit_stub" let bin_read_int_16bit buf ~pos_ref = rewrite_c_error bin_read_int_16bit buf ~pos_ref external bin_read_int_32bit : buf -> pos_ref : pos_ref -> int = "ml_read_int_32bit_stub" let bin_read_int_32bit buf ~pos_ref = rewrite_c_error bin_read_int_32bit buf ~pos_ref external bin_read_int_64bit : buf -> pos_ref : pos_ref -> int = "ml_read_int_64bit_stub" let bin_read_int_64bit buf ~pos_ref = rewrite_c_error bin_read_int_64bit buf ~pos_ref external bin_read_int64_bits : buf -> pos_ref : pos_ref -> int64 = "ml_read_int64_bits_stub" let bin_read_int64_bits buf ~pos_ref = rewrite_c_error bin_read_int64_bits buf ~pos_ref external bin_read_network16_int : buf -> pos_ref : pos_ref -> int = "ml_read_network16_int_stub" let bin_read_network16_int buf ~pos_ref = rewrite_c_error bin_read_network16_int buf ~pos_ref external bin_read_network32_int : buf -> pos_ref : pos_ref -> int = "ml_read_network32_int_stub" let bin_read_network32_int buf ~pos_ref = rewrite_c_error bin_read_network32_int buf ~pos_ref external bin_read_network32_int32 : buf -> pos_ref : pos_ref -> int32 = "ml_read_network32_int32_stub" let bin_read_network32_int32 buf ~pos_ref = rewrite_c_error bin_read_network32_int32 buf ~pos_ref external bin_read_network64_int : buf -> pos_ref : pos_ref -> int = "ml_read_network64_int_stub" let bin_read_network64_int buf ~pos_ref = rewrite_c_error bin_read_network64_int buf ~pos_ref external bin_read_network64_int64 : buf -> pos_ref : pos_ref -> int64 = "ml_read_network64_int64_stub" let bin_read_network64_int64 buf ~pos_ref = rewrite_c_error bin_read_network64_int64 buf ~pos_ref bin_prot-109.30.00/lib/read_ml.mli000066400000000000000000000037771216015522300165270ustar00rootroot00000000000000(** Reading values from the binary protocol using (mostly) OCaml. *) open Common type 'a reader = buf -> pos_ref : pos_ref -> 'a (** Type of reader functions for the binary protocol. They take a buffer and a reference to a read position, and return the unmarshalled value. The next buffer position after reading in the value will be stored in the position reference. *) type ('a, 'b) reader1 = 'a reader -> 'b reader type ('a, 'b, 'c) reader2 = 'a reader -> ('b, 'c) reader1 type ('a, 'b, 'c, 'd) reader3 = 'a reader -> ('b, 'c, 'd) reader2 val bin_read_unit : unit reader val bin_read_bool : bool reader val bin_read_string : string reader val bin_read_char : char reader val bin_read_int : int reader val bin_read_nat0 : Nat0.t reader val bin_read_float : float reader val bin_read_int32 : int32 reader val bin_read_int64 : int64 reader val bin_read_nativeint : nativeint reader val bin_read_ref : ('a, 'a ref) reader1 val bin_read_lazy : ('a, 'a lazy_t) reader1 val bin_read_option : ('a, 'a option) reader1 val bin_read_pair : ('a, 'b, 'a * 'b) reader2 val bin_read_triple : ('a, 'b, 'c, 'a * 'b * 'c) reader3 val bin_read_list : ('a, 'a list) reader1 val bin_read_array : ('a, 'a array) reader1 val bin_read_hashtbl : ('a, 'b, ('a, 'b) Hashtbl.t) reader2 val bin_read_float32_vec : vec32 reader val bin_read_float64_vec : vec64 reader val bin_read_vec : vec reader val bin_read_float32_mat : mat32 reader val bin_read_float64_mat : mat64 reader val bin_read_mat : mat reader val bin_read_bigstring : buf reader val bin_read_float_array : float array reader val bin_read_variant_int : int reader val bin_read_variant_tag : [> ] reader val bin_read_int_8bit : int reader val bin_read_int_16bit : int reader val bin_read_int_32bit : int reader val bin_read_int_64bit : int reader val bin_read_int64_bits : int64 reader val bin_read_network16_int : int reader val bin_read_network32_int : int reader val bin_read_network32_int32 : int32 reader val bin_read_network64_int : int reader val bin_read_network64_int64 : int64 reader bin_prot-109.30.00/lib/read_stubs.c000066400000000000000000000474371216015522300167210ustar00rootroot00000000000000/* Stubs for reading basic values in the binary protocol */ #include "common_stubs.h" /* Initialisation */ static value *v_exc_Error = NULL; static value *v_exc_Read_error = NULL; CAMLprim value bin_prot_unsafe_read_c_init_stub(value __unused v_unit) { v_exc_Error = caml_named_value("Bin_prot.Unsafe_read_c.Error"); return Val_unit; } CAMLprim value bin_prot_read_ml_init_stub(value __unused v_unit) { v_exc_Read_error = caml_named_value("Bin_prot.Common.Read_error"); return Val_unit; } /* Raising errors */ /* Constant values come from the order of variants in common.ml */ #define READ_ERROR_NEG_INT8 0 #define READ_ERROR_INT_CODE 1 #define READ_ERROR_INT_OVERFLOW 2 #define READ_ERROR_NAT0_CODE 3 #define READ_ERROR_NAT0_OVERFLOW 4 #define READ_ERROR_INT32_CODE 5 #define READ_ERROR_INT64_CODE 6 #define READ_ERROR_NATIVEINT_CODE 7 #define READ_ERROR_UNIT_CODE 8 #define READ_ERROR_BOOL_CODE 9 #define READ_ERROR_OPTION_CODE 10 #define READ_ERROR_STRING_TOO_LONG 11 #define READ_ERROR_VARIANT_TAG 12 #define READ_ERROR_ARRAY_TOO_LONG 13 static inline value raise_Error(int loc) Noreturn; static inline value raise_Error(int loc) { caml_raise_with_arg(*v_exc_Error, Val_int(loc)); } static inline void raise_Read_error(int loc, unsigned long pos) Noreturn; static inline void raise_Read_error(int loc, unsigned long pos) { value v_exc = caml_alloc_small(3, 0); Field(v_exc, 0) = *v_exc_Read_error; Field(v_exc, 1) = Val_int(loc); Field(v_exc, 2) = Val_long(pos); caml_raise(v_exc); } /* Utility macros */ #define MK_GEN_SAFE_READ(NAME, SIZE, TYPE, LEN, CHECK) \ static inline TYPE safe_read_##NAME##SIZE(char **sptr_ptr, char *eptr) \ { \ char *sptr = *sptr_ptr; \ char *next = sptr + LEN; \ TYPE n; \ if (unlikely(next > eptr)) \ caml_raise_constant(*v_bin_prot_exc_Buffer_short); \ n = le##SIZE##dec(sptr); \ CHECK \ *sptr_ptr = next; \ return n; \ } #define MK_SAFE_READ(SIZE, TYPE, LEN, CHECK) \ MK_GEN_SAFE_READ(int, SIZE, TYPE, LEN, CHECK) #define MK_GEN_SAFE_NAT0_READ(PREF, SIZE, TYPE, LEN, CHECK) \ MK_GEN_SAFE_READ(PREF##nat0_, SIZE, unsigned TYPE, LEN, CHECK) #define MK_SAFE_NAT0_READ(SIZE, TYPE, LEN, CHECK) \ MK_GEN_SAFE_READ(nat0_, SIZE, unsigned TYPE, LEN, CHECK) #define MK_ML_READER(NAME) \ CAMLprim value ml_read_##NAME##_stub(value v_buf, value v_pos_ref) \ { \ CAMLparam2(v_buf, v_pos_ref); \ struct caml_ba_array *buf = Caml_ba_array_val(v_buf); \ char *start = buf->data; \ long pos = Long_val(Field(v_pos_ref, 0)); \ char *sptr = start + pos; \ char **sptr_ptr = &sptr; \ char *eptr = start + *buf->dim; \ value v_res; \ if (unlikely(pos < 0)) caml_array_bound_error(); \ v_res = read_##NAME##_stub(sptr_ptr, eptr); \ Field(v_pos_ref, 0) = Val_long(sptr - start); \ CAMLreturn(v_res); \ } /* Reading OCaml integers */ MK_GEN_SAFE_READ(neg_int, 8, char, 1, if (unlikely(n >= 0)) { *sptr_ptr = sptr - 1; raise_Error(READ_ERROR_NEG_INT8); }) MK_SAFE_READ(16, short, 2, {}) #ifdef ARCH_SIXTYFOUR MK_SAFE_READ(32, int, 4, {}) #else MK_GEN_SAFE_READ(int, 32, int, 4, if (unlikely(n < -0x40000000l || n > 0x3FFFFFFFl)) { *sptr_ptr = sptr - 1; raise_Error(READ_ERROR_INT_OVERFLOW); }) MK_GEN_SAFE_READ(nocheck_int, 32, int, 4, {}) #endif #ifdef ARCH_SIXTYFOUR MK_SAFE_READ(64, long, 8, if (unlikely(n < -0x4000000000000000L || n > 0x3FFFFFFFFFFFFFFFL)) { *sptr_ptr = sptr - 1; raise_Error(READ_ERROR_INT_OVERFLOW); }) MK_GEN_SAFE_READ(nocheck_int, 64, long, 8, {}) #endif static inline long read_int(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; int code; if (unlikely(sptr >= eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); code = *sptr; *sptr_ptr = sptr + 1; if (likely(code >= 0)) return code; if (likely(code == CODE_INT16)) return safe_read_int16(sptr_ptr, eptr); if (likely(code == CODE_NEG_INT8)) return safe_read_neg_int8(sptr_ptr, eptr); if (likely(code == CODE_INT32)) return safe_read_int32(sptr_ptr, eptr); #ifdef ARCH_SIXTYFOUR if (likely(code == CODE_INT64)) return safe_read_int64(sptr_ptr, eptr); #endif *sptr_ptr = sptr; raise_Error(READ_ERROR_INT_CODE); } CAMLprim value read_int_stub(char **sptr_ptr, char *eptr) { return Val_long(read_int(sptr_ptr, eptr)); } /* Non-negative OCaml integers */ MK_SAFE_NAT0_READ(16, short, 2, {}) #ifdef ARCH_SIXTYFOUR MK_SAFE_NAT0_READ(32, int, 4, {}) #else MK_SAFE_NAT0_READ(32, int, 4, if (unlikely(n > 0x3FFFFFFFl)) { *sptr_ptr = sptr - 1; raise_Error(READ_ERROR_NAT0_OVERFLOW); }) MK_GEN_SAFE_NAT0_READ(nocheck, 32, int, 4, {}) #endif #ifdef ARCH_SIXTYFOUR MK_SAFE_NAT0_READ(64, long, 8, if (unlikely(n > 0x3FFFFFFFFFFFFFFFL)) { *sptr_ptr = sptr - 1; raise_Error(READ_ERROR_NAT0_OVERFLOW); }) #endif static inline unsigned long read_nat0(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; int code; if (unlikely(sptr >= eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); code = *sptr; *sptr_ptr = sptr + 1; if (likely(code >= 0)) return code; if (likely(code == CODE_INT16)) return safe_read_nat0_16(sptr_ptr, eptr); if (likely(code == CODE_INT32)) return safe_read_nat0_32(sptr_ptr, eptr); #ifdef ARCH_SIXTYFOUR if (likely(code == CODE_INT64)) return safe_read_nat0_64(sptr_ptr, eptr); #endif *sptr_ptr = sptr; raise_Error(READ_ERROR_NAT0_CODE); } CAMLprim value read_nat0_stub(char **sptr_ptr, char *eptr) { return Val_long(read_nat0(sptr_ptr, eptr)); } /* Reading 32bit integers */ static inline long read_int32(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; int code; if (unlikely(sptr >= eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); code = *sptr; *sptr_ptr = sptr + 1; if (likely(code >= 0)) return code; if (likely(code == CODE_INT16)) return safe_read_int16(sptr_ptr, eptr); if (likely(code == CODE_NEG_INT8)) return safe_read_neg_int8(sptr_ptr, eptr); if (likely(code == CODE_INT32)) #ifdef ARCH_SIXTYFOUR return safe_read_int32(sptr_ptr, eptr); #else return safe_read_nocheck_int32(sptr_ptr, eptr); #endif *sptr_ptr = sptr; raise_Error(READ_ERROR_INT32_CODE); } CAMLprim value read_int32_stub(char **sptr_ptr, char *eptr) { return caml_copy_int32(read_int32(sptr_ptr, eptr)); } /* Reading 64bit integers */ static inline int64 read_int64(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; int code; if (unlikely(sptr >= eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); code = *sptr; *sptr_ptr = sptr + 1; #ifdef ARCH_SIXTYFOUR if (likely(code >= 0)) return code; if (likely(code == CODE_INT16)) return safe_read_int16(sptr_ptr, eptr); if (likely(code == CODE_NEG_INT8)) return safe_read_neg_int8(sptr_ptr, eptr); if (likely(code == CODE_INT32)) return safe_read_int32(sptr_ptr, eptr); if (likely(code == CODE_INT64)) return safe_read_nocheck_int64(sptr_ptr, eptr); #else if (likely(code >= 0)) return I64_literal(0, code); if (likely(code == CODE_INT16)) return I64_of_int32(safe_read_int16(sptr_ptr, eptr)); if (likely(code == CODE_NEG_INT8)) return I64_literal(0xFFFFFFFF, safe_read_neg_int8(sptr_ptr, eptr)); if (likely(code == CODE_INT32)) return I64_of_int32(safe_read_nocheck_int32(sptr_ptr, eptr)); if (likely(code == CODE_INT64)) { unsigned int l = safe_read_nocheck_int32(sptr_ptr, eptr); return I64_literal(safe_read_nocheck_int32(sptr_ptr, eptr), l); } #endif *sptr_ptr = sptr; raise_Error(READ_ERROR_INT64_CODE); } CAMLprim value read_int64_stub(char **sptr_ptr, char *eptr) { return caml_copy_int64(read_int64(sptr_ptr, eptr)); } /* Reading nativeints */ static inline long read_nativeint(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; int code; if (unlikely(sptr >= eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); code = *sptr; *sptr_ptr = sptr + 1; if (likely(code >= 0)) return code; if (likely(code == CODE_INT16)) return safe_read_int16(sptr_ptr, eptr); if (likely(code == CODE_NEG_INT8)) return safe_read_neg_int8(sptr_ptr, eptr); #ifdef ARCH_SIXTYFOUR if (likely(code == CODE_INT32)) return safe_read_int32(sptr_ptr, eptr); if (likely(code == CODE_INT64)) return safe_read_nocheck_int64(sptr_ptr, eptr); #else if (likely(code == CODE_INT32)) return safe_read_nocheck_int32(sptr_ptr, eptr); #endif *sptr_ptr = sptr; raise_Error(READ_ERROR_NATIVEINT_CODE); } CAMLprim value read_nativeint_stub(char **sptr_ptr, char *eptr) { return caml_copy_nativeint(read_nativeint(sptr_ptr, eptr)); } /* Reading unit value */ CAMLprim value read_unit_stub(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; int res; if (unlikely(sptr >= eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); res = *sptr; if (res == 0) { *sptr_ptr = ++sptr; return Val_unit; } raise_Error(READ_ERROR_UNIT_CODE); } /* Reading booleans and options */ #define READ_ZERO_OR_ONE(NAME, CODE) \ CAMLprim value read_##NAME##_stub(char **sptr_ptr, char *eptr) \ { \ char *sptr = *sptr_ptr; \ int res; \ if (unlikely(sptr >= eptr)) \ caml_raise_constant(*v_bin_prot_exc_Buffer_short); \ res = *sptr; \ if (res == 0) { *sptr_ptr = ++sptr; return Val_int(0); } \ if (res == 1) { *sptr_ptr = ++sptr; return Val_int(1); } \ raise_Error(CODE); \ } READ_ZERO_OR_ONE(bool, READ_ERROR_BOOL_CODE) READ_ZERO_OR_ONE(option_bool, READ_ERROR_OPTION_CODE) /* Reading characters */ CAMLprim value read_char_stub(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; unsigned char res; if (unlikely(sptr >= eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); res = (unsigned char) *sptr; *sptr_ptr = ++sptr; return Val_int(res); } MK_ML_READER(char) /* Reading strings */ CAMLprim value read_string_stub(char **sptr_ptr, char *eptr) { value v_res; char *start = *sptr_ptr; unsigned long len = read_nat0(sptr_ptr, eptr); char *sptr = *sptr_ptr; char *next = sptr + len; if (unlikely(len > Bsize_wsize(Max_wosize) - 1)) { *sptr_ptr = start; raise_Error(READ_ERROR_STRING_TOO_LONG); } if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *sptr_ptr = next; v_res = caml_alloc_string(len); memcpy(String_val(v_res), sptr, len); return v_res; } /* Reading floats and float arrays */ CAMLprim inline value read_float_stub(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; char *next = sptr + sizeof(double); double n; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *sptr_ptr = next; memcpy(&n, sptr, sizeof(double)); return caml_copy_double(n); } MK_ML_READER(float) CAMLprim value read_float_array_stub(char **sptr_ptr, char *eptr) { char *start = *sptr_ptr; unsigned long len = read_nat0(sptr_ptr, eptr); unsigned long tot_size; unsigned long wsize; char *sptr; char *next; value v_res; if (unlikely(len == 0)) return Atom(0); wsize = len * Double_wosize; if (unlikely(wsize > Max_wosize)) { *sptr_ptr = start; raise_Error(READ_ERROR_ARRAY_TOO_LONG); } sptr = *sptr_ptr; tot_size = len * sizeof(double); next = sptr + tot_size; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *sptr_ptr = next; v_res = caml_alloc(wsize, Double_array_tag); memcpy((double *) v_res, sptr, tot_size); return v_res; } CAMLprim value ml_read_float_array_stub(value v_buf, value v_pos_ref) { CAMLparam2(v_buf, v_pos_ref); struct caml_ba_array *buf = Caml_ba_array_val(v_buf); char *start = buf->data; long pos = Long_val(Field(v_pos_ref, 0)); char *sptr = start + pos; char **sptr_ptr = &sptr; char *eptr = start + *buf->dim; value v_res; unsigned long len; unsigned long tot_size; unsigned long wsize; char *next; if (unlikely(pos < 0)) caml_array_bound_error(); len = read_nat0(sptr_ptr, eptr); if (unlikely(len == 0)) { Field(v_pos_ref, 0) = Val_long(sptr - start); CAMLreturn(Atom(0)); } wsize = len * Double_wosize; if (unlikely(wsize > Max_wosize)) raise_Read_error(READ_ERROR_ARRAY_TOO_LONG, pos); tot_size = len * sizeof(double); next = sptr + tot_size; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); v_res = caml_alloc(wsize, Double_array_tag); memcpy((double *) v_res, sptr, tot_size); Field(v_pos_ref, 0) = Val_long(next - start); CAMLreturn(v_res); } /* Reading polymorphic variants */ CAMLprim value read_variant_tag_stub(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; char *next = sptr + 4; int n; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); n = le32dec(sptr); if (likely(Is_long(n))) { *sptr_ptr = next; return (value) n; } raise_Error(READ_ERROR_VARIANT_TAG); } CAMLprim value ml_read_variant_tag_stub(value v_buf, value v_pos_ref) { struct caml_ba_array *buf = Caml_ba_array_val(v_buf); char *start = buf->data; long pos = Long_val(Field(v_pos_ref, 0)); char *sptr = start + pos; unsigned long next_pos = (unsigned long) pos + 4; int n; if (unlikely(pos < 0)) caml_array_bound_error(); if (unlikely(next_pos > (unsigned long) *buf->dim)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); n = le32dec(sptr); if (likely(Is_long(n))) { Field(v_pos_ref, 0) = Val_long(next_pos); return (value) n; } else raise_Read_error(READ_ERROR_VARIANT_TAG, pos); } /* Reading raw strings */ CAMLprim inline value read_raw_string_stub( char **sptr_ptr, char *eptr, value v_str, value v_pos, value v_len) { size_t pos = (size_t) Long_val(v_pos), len = (size_t) Long_val(v_len); char *sptr = *sptr_ptr; char *next = sptr + len; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *sptr_ptr = next; memcpy(String_val(v_str) + pos, sptr, len); return Val_unit; } /* Reading bigarrays */ #define MK_BA1_READER(NAME, TYPE, TFLAG, TLAYOUT) \ CAMLprim inline value read_##NAME##_stub(char **sptr_ptr, char *eptr) \ { \ unsigned long len = read_nat0(sptr_ptr, eptr); \ unsigned long tot_size = len * sizeof(TYPE); \ char *sptr = *sptr_ptr; \ char *next = sptr + tot_size; \ intnat dim; \ value v_res; \ if (unlikely(next > eptr)) \ caml_raise_constant(*v_bin_prot_exc_Buffer_short); \ dim = len; \ v_res = \ caml_ba_alloc( \ CAML_BA_##TFLAG | CAML_BA_##TLAYOUT##_LAYOUT, 1, NULL, &dim); \ *sptr_ptr = next; \ if (unlikely(tot_size > 65536)) { \ Begin_roots1(v_res); \ caml_enter_blocking_section(); \ memcpy((TYPE *) Caml_ba_data_val(v_res), sptr, tot_size); \ caml_leave_blocking_section(); \ End_roots(); \ } else memcpy((TYPE *) Caml_ba_data_val(v_res), sptr, tot_size); \ return v_res; \ } \ \ MK_ML_READER(NAME) MK_BA1_READER(bigstring, char, UINT8, C) #define MK_VEC_MAT_READERS(NAME, TYPE, TFLAG) \ MK_BA1_READER(NAME##_vec, TYPE, TFLAG, FORTRAN) \ \ CAMLprim inline value read_##NAME##_mat_stub(char **sptr_ptr, char *eptr) \ { \ unsigned long dim1 = read_nat0(sptr_ptr, eptr); \ unsigned long dim2 = read_nat0(sptr_ptr, eptr); \ unsigned long size = dim1 * dim2; \ unsigned long tot_size = size * sizeof(TYPE); \ char *sptr = *sptr_ptr; \ char *next = sptr + tot_size; \ intnat dims[2]; \ value v_res; \ if (unlikely(next > eptr)) \ caml_raise_constant(*v_bin_prot_exc_Buffer_short); \ dims[0] = dim1; \ dims[1] = dim2; \ v_res = \ caml_ba_alloc( \ CAML_BA_##TFLAG | CAML_BA_FORTRAN_LAYOUT, 2, NULL, dims); \ *sptr_ptr = next; \ if (unlikely(tot_size > 65536)) { \ Begin_roots1(v_res); \ caml_enter_blocking_section(); \ memcpy((TYPE *) Caml_ba_data_val(v_res), sptr, tot_size); \ caml_leave_blocking_section(); \ End_roots(); \ } else memcpy((TYPE *) Caml_ba_data_val(v_res), sptr, tot_size); \ return v_res; \ } \ \ MK_ML_READER(NAME##_mat) MK_VEC_MAT_READERS(float32, float, FLOAT32) MK_VEC_MAT_READERS(float64, double, FLOAT64) /* Reading bits */ CAMLprim value read_int_16bit_stub(char **sptr_ptr, char *eptr) { unsigned short res = safe_read_nat0_16(sptr_ptr, eptr); return Val_int(res); } MK_ML_READER(int_16bit) CAMLprim value read_int_32bit_stub(char **sptr_ptr, char *eptr) { unsigned int res = safe_read_nat0_32(sptr_ptr, eptr); return Val_int(res); } MK_ML_READER(int_32bit) CAMLprim inline value read_int_64bit_stub(char **sptr_ptr, char *eptr) { long n; #ifndef ARCH_SIXTYFOUR long upper; #endif char *sptr = *sptr_ptr; char *next = sptr + 8; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); #ifdef ARCH_SIXTYFOUR n = le64dec(sptr); if (unlikely(n < -0x4000000000000000L || n > 0x3FFFFFFFFFFFFFFFL)) raise_Error(READ_ERROR_INT_OVERFLOW); #else n = le32dec(sptr); memcpy(&upper, sptr + 4, 4); if (upper == 0l) { if ((unsigned long) n > 0x3FFFFFFFl) raise_Error(READ_ERROR_INT_OVERFLOW); } else if (upper == -1) { if (n < -0x40000000l) raise_Error(READ_ERROR_INT_OVERFLOW); } else raise_Error(READ_ERROR_INT_OVERFLOW); #endif *sptr_ptr = next; return Val_long(n); } MK_ML_READER(int_64bit) CAMLprim inline value read_int64_bits_stub(char **sptr_ptr, char *eptr) { int64 n; value v_res; char *sptr = *sptr_ptr; char *next = sptr + 8; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); #ifdef ARCH_SIXTYFOUR n = le64dec(sptr); #else n = I64_literal(le32dec(sptr + 4), le32dec(sptr)); #endif v_res = caml_copy_int64(n); *sptr_ptr = next; return (value) v_res; } MK_ML_READER(int64_bits) CAMLprim inline value read_network16_int_stub(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; char *next = sptr + 2; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *sptr_ptr = next; return (value) Val_int(be16dec(sptr)); } MK_ML_READER(network16_int) CAMLprim inline value read_network32_int_stub(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; char *next = sptr + 4; int n; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); n = (int) be32dec(sptr); #ifdef ARCH_SIXTYFOUR *sptr_ptr = next; return (value) Val_int((uint32_t) n); #else if (unlikely(n < -0x40000000l || n > 0x3FFFFFFFl)) raise_Error(READ_ERROR_INT_OVERFLOW); *sptr_ptr = next; return (value) Val_int(n); #endif } MK_ML_READER(network32_int) CAMLprim inline value read_network32_int32_stub(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; char *next = sptr + 4; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *sptr_ptr = next; return (value) caml_copy_int32(be32dec(sptr)); } MK_ML_READER(network32_int32) CAMLprim inline value read_network64_int_stub(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; char *next = sptr + 8; long n; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); #ifdef ARCH_SIXTYFOUR n = (long) be64dec(sptr); if (unlikely(n < -0x4000000000000000L || n > 0x3FFFFFFFFFFFFFFFL)) raise_Error(READ_ERROR_INT_OVERFLOW); #else /* 32bit */ /* Read the upper 32 bits first. They must all be zero, otherwise we consider this an overflow. On 32bit platforms the integer must fit completely into one word. */ memcpy(&n, sptr, 4); if (n != 0) raise_Error(READ_ERROR_INT_OVERFLOW); n = be32dec(sptr + 4); if (unlikely(n < -0x40000000l || n > 0x3FFFFFFFl)) raise_Error(READ_ERROR_INT_OVERFLOW); #endif *sptr_ptr = next; return (value) Val_long(n); } MK_ML_READER(network64_int) CAMLprim inline value read_network64_int64_stub(char **sptr_ptr, char *eptr) { char *sptr = *sptr_ptr; char *next = sptr + 8; int64 n; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *sptr_ptr = next; #ifdef ARCH_SIXTYFOUR n = (long) be64dec(sptr); #else /* 32bit */ n = I64_literal(be32dec(sptr), be32dec(sptr + 4)); #endif return (value) caml_copy_int64(n); } MK_ML_READER(network64_int64) bin_prot-109.30.00/lib/size.ml000066400000000000000000000106031216015522300157070ustar00rootroot00000000000000(* Size: compute size of values in the binary protocol. *) open Bigarray open Common type 'a sizer = 'a -> int type ('a, 'b) sizer1 = 'a sizer -> 'b sizer type ('a, 'b, 'c) sizer2 = 'a sizer -> ('b, 'c) sizer1 type ('a, 'b, 'c, 'd) sizer3 = 'a sizer -> ('b, 'c, 'd) sizer2 let bin_size_unit () = 1 let bin_size_bool _ = 1 let bin_size_int_nat0 n = if n < 0x00000080 then 1 else if n < 0x00008000 then 3 #ifdef ARCH_SIXTYFOUR else if n >= 0x80000000 then 9 #endif else 5 let bin_size_int_negative n = if n >= -0x00000080 then 2 else if n >= -0x00008000 then 3 #ifdef ARCH_SIXTYFOUR else if n < -0x80000000 then 9 #endif else 5 let bin_size_char _ = 1 let bin_size_int n = if n >= 0 then bin_size_int_nat0 n else bin_size_int_negative n let bin_size_nat0 nat0 = let n = (nat0 : Nat0.t :> int) in if n < 0x00000080 then 1 else if n < 0x00010000 then 3 #ifdef ARCH_SIXTYFOUR else if n >= 0x100000000 then 9 #endif else 5 let bin_size_string str = let len = String.length str in let plen = Nat0.unsafe_of_int len in let size_len = bin_size_nat0 plen in size_len + len let bin_size_float _ = 8 #ifdef ARCH_SIXTYFOUR let bin_size_int32 n = bin_size_int (Int32.to_int n) #else let bin_size_int32 n = if n >= 0x00008000l || n < -0x00008000l then 5 else bin_size_int (Int32.to_int n) #endif #ifdef ARCH_SIXTYFOUR let bin_size_int64 n = if n >= 0x80000000L || n < -0x80000000L then 9 else bin_size_int (Int64.to_int n) #else let bin_size_int64 n = if n >= 0x80000000L || n < -0x80000000L then 9 else bin_size_int32 (Int64.to_int32 n) #endif let bin_size_nativeint n = #ifdef ARCH_SIXTYFOUR bin_size_int64 (Int64.of_nativeint n) #else bin_size_int32 (Nativeint.to_int32 n) #endif let bin_size_ref bin_size_el r = bin_size_el !r let bin_size_lazy_t bin_size_el lv = bin_size_el (Lazy.force lv) let bin_size_lazy = bin_size_lazy_t let bin_size_option bin_size_el = function | None -> 1 | Some v -> 1 + bin_size_el v let bin_size_pair bin_size_a bin_size_b (a, b) = bin_size_a a + bin_size_b b let bin_size_triple bin_size_a bin_size_b bin_size_c (a, b, c) = bin_size_a a + bin_size_b b + bin_size_c c let bin_size_list bin_size_el lst = let rec loop len = function | [] -> len | h :: t -> loop (len + bin_size_el h) t in let len = Nat0.unsafe_of_int (List.length lst) in let size_len = bin_size_nat0 len in loop size_len lst let bin_size_len len = let plen = Nat0.unsafe_of_int len in bin_size_nat0 plen let bin_size_array_loop bin_size_el ar ~total_len ~n = let total_len_ref = ref total_len in for i = 0 to n - 1 do let el = Array.unsafe_get ar i in total_len_ref := !total_len_ref + bin_size_el el done; !total_len_ref let bin_size_array bin_size_el ar = let n = Array.length ar in let total_len = bin_size_len n in bin_size_array_loop bin_size_el ar ~total_len ~n let bin_size_hashtbl bin_size_key bin_size_val htbl = let cnt_ref = ref 0 in let coll_htbl k v total_len = incr cnt_ref; total_len + bin_size_key k + bin_size_val v in let len = Hashtbl.length htbl in let total_len = Hashtbl.fold coll_htbl htbl (bin_size_len len) in if !cnt_ref <> len then raise_concurrent_modification "bin_size_hashtbl"; total_len let bin_size_gen_vec vec multiplier = let len = Array1.dim vec in bin_size_len len + multiplier * len let bin_size_float32_vec vec = bin_size_gen_vec vec 4 let bin_size_float64_vec vec = bin_size_gen_vec vec 8 let bin_size_vec = bin_size_float64_vec let bin_size_gen_mat mat multiplier = let dim1 = Array2.dim1 mat in let dim2 = Array2.dim2 mat in let size = dim1 * dim2 in bin_size_len dim1 + bin_size_len dim2 + multiplier * size let bin_size_float32_mat mat = bin_size_gen_mat mat 4 let bin_size_float64_mat mat = bin_size_gen_mat mat 8 let bin_size_mat = bin_size_float64_mat let bin_size_bigstring buf = bin_size_gen_vec buf 1 let bin_size_float_array ar = let len = Array.length ar in bin_size_len len + 8 * len let bin_size_variant_tag _ = 4 let bin_size_int_8bit _ = 1 let bin_size_int_16bit _ = 2 let bin_size_int_32bit _ = 4 let bin_size_int_64bit _ = 8 let bin_size_int64_bits _ = 8 let bin_size_network16_int _ = 2 let bin_size_network32_int _ = 4 let bin_size_network32_int32 _ = 4 let bin_size_network64_int _ = 8 let bin_size_network64_int64 _ = 8 let bin_size_array_no_length bin_size_el ar = bin_size_array_loop bin_size_el ar ~total_len:0 ~n:(Array.length ar) bin_prot-109.30.00/lib/size.mli000066400000000000000000000033501216015522300160610ustar00rootroot00000000000000(** Compute size of values in the binary protocol. *) open Common type 'a sizer = 'a -> int type ('a, 'b) sizer1 = 'a sizer -> 'b sizer type ('a, 'b, 'c) sizer2 = 'a sizer -> ('b, 'c) sizer1 type ('a, 'b, 'c, 'd) sizer3 = 'a sizer -> ('b, 'c, 'd) sizer2 val bin_size_unit : unit sizer val bin_size_bool : bool sizer val bin_size_string : string sizer val bin_size_char : char sizer val bin_size_int : int sizer val bin_size_float : float sizer val bin_size_int32 : int32 sizer val bin_size_int64 : int64 sizer val bin_size_nativeint : nativeint sizer val bin_size_nat0 : Nat0.t sizer val bin_size_ref : ('a, 'a ref) sizer1 val bin_size_lazy_t : ('a, 'a lazy_t) sizer1 val bin_size_lazy : ('a, 'a lazy_t) sizer1 val bin_size_option : ('a, 'a option) sizer1 val bin_size_pair : ('a, 'b, 'a * 'b) sizer2 val bin_size_triple : ('a, 'b, 'c, 'a * 'b * 'c) sizer3 val bin_size_list : ('a, 'a list) sizer1 val bin_size_array : ('a, 'a array) sizer1 val bin_size_hashtbl : ('a, 'b, ('a, 'b) Hashtbl.t) sizer2 val bin_size_float32_vec : vec32 sizer val bin_size_float64_vec : vec64 sizer val bin_size_vec : vec sizer val bin_size_float32_mat : mat32 sizer val bin_size_float64_mat : mat64 sizer val bin_size_mat : mat sizer val bin_size_bigstring : buf sizer val bin_size_float_array : float array sizer val bin_size_variant_tag : [> ] sizer val bin_size_int_8bit : int sizer val bin_size_int_16bit : int sizer val bin_size_int_32bit : int sizer val bin_size_int_64bit : int sizer val bin_size_int64_bits : int64 sizer val bin_size_network16_int : int sizer val bin_size_network32_int : int sizer val bin_size_network32_int32 : int32 sizer val bin_size_network64_int : int sizer val bin_size_network64_int64 : int64 sizer val bin_size_array_no_length : ('a, 'a array) sizer1 bin_prot-109.30.00/lib/std.ml000066400000000000000000000242401216015522300155310ustar00rootroot00000000000000(** This module defines default converters for the types defined in the OCaml standard library. *) include Size let bin_unit = Type_class.bin_unit let bin_writer_unit = Type_class.bin_writer_unit let bin_write_unit_ = Unsafe_write_c.bin_write_unit let bin_write_unit = Write_ml.bin_write_unit let bin_reader_unit = Type_class.bin_reader_unit let bin_read_unit = Read_ml.bin_read_unit let bin_read_unit_ = Unsafe_read_c.bin_read_unit let bin_read_unit__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "unit" let bin_bool = Type_class.bin_bool let bin_writer_bool = Type_class.bin_writer_bool let bin_write_bool_ = Unsafe_write_c.bin_write_bool let bin_write_bool = Write_ml.bin_write_bool let bin_reader_bool = Type_class.bin_reader_bool let bin_read_bool = Read_ml.bin_read_bool let bin_read_bool_ = Unsafe_read_c.bin_read_bool let bin_read_bool__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "bool" let bin_string = Type_class.bin_string let bin_writer_string = Type_class.bin_writer_string let bin_write_string_ = Unsafe_write_c.bin_write_string let bin_write_string = Write_ml.bin_write_string let bin_reader_string = Type_class.bin_reader_string let bin_read_string = Read_ml.bin_read_string let bin_read_string_ = Unsafe_read_c.bin_read_string let bin_read_string__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "string" let bin_char = Type_class.bin_char let bin_writer_char = Type_class.bin_writer_char let bin_write_char_ = Unsafe_write_c.bin_write_char let bin_write_char = Write_ml.bin_write_char let bin_reader_char = Type_class.bin_reader_char let bin_read_char = Read_ml.bin_read_char let bin_read_char_ = Unsafe_read_c.bin_read_char let bin_read_char__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "char" let bin_int = Type_class.bin_int let bin_writer_int = Type_class.bin_writer_int let bin_write_int_ = Unsafe_write_c.bin_write_int let bin_write_int = Write_ml.bin_write_int let bin_reader_int = Type_class.bin_reader_int let bin_read_int = Read_ml.bin_read_int let bin_read_int_ = Unsafe_read_c.bin_read_int let bin_read_int__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "int" let bin_float = Type_class.bin_float let bin_writer_float = Type_class.bin_writer_float let bin_write_float_ = Unsafe_write_c.bin_write_float let bin_write_float = Write_ml.bin_write_float let bin_reader_float = Type_class.bin_reader_float let bin_read_float = Read_ml.bin_read_float let bin_read_float_ = Unsafe_read_c.bin_read_float let bin_read_float__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "float" let bin_int32 = Type_class.bin_int32 let bin_writer_int32 = Type_class.bin_writer_int32 let bin_write_int32_ = Unsafe_write_c.bin_write_int32 let bin_write_int32 = Write_ml.bin_write_int32 let bin_reader_int32 = Type_class.bin_reader_int32 let bin_read_int32 = Read_ml.bin_read_int32 let bin_read_int32_ = Unsafe_read_c.bin_read_int32 let bin_read_int32__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "int32" let bin_int64 = Type_class.bin_int64 let bin_writer_int64 = Type_class.bin_writer_int64 let bin_write_int64_ = Unsafe_write_c.bin_write_int64 let bin_write_int64 = Write_ml.bin_write_int64 let bin_reader_int64 = Type_class.bin_reader_int64 let bin_read_int64 = Read_ml.bin_read_int64 let bin_read_int64_ = Unsafe_read_c.bin_read_int64 let bin_read_int64__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "int64" let bin_nativeint = Type_class.bin_nativeint let bin_writer_nativeint = Type_class.bin_writer_nativeint let bin_write_nativeint_ = Unsafe_write_c.bin_write_nativeint let bin_write_nativeint = Write_ml.bin_write_nativeint let bin_reader_nativeint = Type_class.bin_reader_nativeint let bin_read_nativeint = Read_ml.bin_read_nativeint let bin_read_nativeint_ = Unsafe_read_c.bin_read_nativeint let bin_read_nativeint__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "nativeint" let bin_ref = Type_class.bin_ref let bin_writer_ref = Type_class.bin_writer_ref let bin_write_ref_ = Unsafe_write_c.bin_write_ref let bin_write_ref = Write_ml.bin_write_ref let bin_reader_ref = Type_class.bin_reader_ref let bin_read_ref = Read_ml.bin_read_ref let bin_read_ref_ = Unsafe_read_c.bin_read_ref let bin_read_ref__ _f _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "ref" let bin_lazy_t = Type_class.bin_lazy let bin_writer_lazy_t = Type_class.bin_writer_lazy let bin_write_lazy_t_ = Unsafe_write_c.bin_write_lazy let bin_write_lazy_t = Write_ml.bin_write_lazy let bin_reader_lazy_t = Type_class.bin_reader_lazy let bin_read_lazy_t = Read_ml.bin_read_lazy let bin_read_lazy_t_ = Unsafe_read_c.bin_read_lazy let bin_read_lazy_t__ _f _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "lazy" let bin_lazy = Type_class.bin_lazy let bin_writer_lazy = Type_class.bin_writer_lazy let bin_write_lazy_ = Unsafe_write_c.bin_write_lazy let bin_write_lazy = Write_ml.bin_write_lazy let bin_reader_lazy = Type_class.bin_reader_lazy let bin_read_lazy = Read_ml.bin_read_lazy let bin_read_lazy_ = Unsafe_read_c.bin_read_lazy let bin_read_lazy__ _f _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "lazy" let bin_option = Type_class.bin_option let bin_writer_option = Type_class.bin_writer_option let bin_write_option_ = Unsafe_write_c.bin_write_option let bin_write_option = Write_ml.bin_write_option let bin_reader_option = Type_class.bin_reader_option let bin_read_option = Read_ml.bin_read_option let bin_read_option_ = Unsafe_read_c.bin_read_option let bin_read_option__ _f _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "option" let bin_list = Type_class.bin_list let bin_writer_list = Type_class.bin_writer_list let bin_write_list_ = Unsafe_write_c.bin_write_list let bin_write_list = Write_ml.bin_write_list let bin_reader_list = Type_class.bin_reader_list let bin_read_list = Read_ml.bin_read_list let bin_read_list_ = Unsafe_read_c.bin_read_list let bin_read_list__ _f _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "list" let bin_array = Type_class.bin_array let bin_writer_array = Type_class.bin_writer_array let bin_write_array_ = Unsafe_write_c.bin_write_array let bin_write_array = Write_ml.bin_write_array let bin_reader_array = Type_class.bin_reader_array let bin_read_array = Read_ml.bin_read_array let bin_read_array_ = Unsafe_read_c.bin_read_array let bin_read_array__ _f _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "array" let bin_hashtbl = Type_class.bin_hashtbl let bin_writer_hashtbl = Type_class.bin_writer_hashtbl let bin_write_hashtbl_ = Unsafe_write_c.bin_write_hashtbl let bin_write_hashtbl = Write_ml.bin_write_hashtbl let bin_reader_hashtbl = Type_class.bin_reader_hashtbl let bin_read_hashtbl = Read_ml.bin_read_hashtbl let bin_read_hashtbl_ = Unsafe_read_c.bin_read_hashtbl let bin_read_hashtbl__ _f _g _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "hashtbl" let bin_bigstring = Type_class.bin_bigstring let bin_writer_bigstring = Type_class.bin_writer_bigstring let bin_write_bigstring_ = Unsafe_write_c.bin_write_bigstring let bin_write_bigstring = Write_ml.bin_write_bigstring let bin_reader_bigstring = Type_class.bin_reader_bigstring let bin_read_bigstring = Read_ml.bin_read_bigstring let bin_read_bigstring_ = Unsafe_read_c.bin_read_bigstring let bin_read_bigstring__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "bigstring" let bin_mat = Type_class.bin_mat let bin_writer_mat = Type_class.bin_writer_mat let bin_write_mat_ = Unsafe_write_c.bin_write_mat let bin_write_mat = Write_ml.bin_write_mat let bin_reader_mat = Type_class.bin_reader_mat let bin_read_mat = Read_ml.bin_read_mat let bin_read_mat_ = Unsafe_read_c.bin_read_mat let bin_read_mat__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "mat" let bin_float32_mat = Type_class.bin_float32_mat let bin_writer_float32_mat = Type_class.bin_writer_float32_mat let bin_write_float32_mat_ = Unsafe_write_c.bin_write_float32_mat let bin_write_float32_mat = Write_ml.bin_write_float32_mat let bin_reader_float32_mat = Type_class.bin_reader_float32_mat let bin_read_float32_mat = Read_ml.bin_read_float32_mat let bin_read_float32_mat_ = Unsafe_read_c.bin_read_float32_mat let bin_read_float32_mat__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "float32_mat" let bin_float64_mat = Type_class.bin_float64_mat let bin_writer_float64_mat = Type_class.bin_writer_float64_mat let bin_write_float64_mat_ = Unsafe_write_c.bin_write_float64_mat let bin_write_float64_mat = Write_ml.bin_write_float64_mat let bin_reader_float64_mat = Type_class.bin_reader_float64_mat let bin_read_float64_mat = Read_ml.bin_read_float64_mat let bin_read_float64_mat_ = Unsafe_read_c.bin_read_float64_mat let bin_read_float64_mat__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "float64_mat" let bin_vec = Type_class.bin_vec let bin_writer_vec = Type_class.bin_writer_vec let bin_write_vec_ = Unsafe_write_c.bin_write_vec let bin_write_vec = Write_ml.bin_write_vec let bin_reader_vec = Type_class.bin_reader_vec let bin_read_vec = Read_ml.bin_read_vec let bin_read_vec_ = Unsafe_read_c.bin_read_vec let bin_read_vec__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "vec" let bin_float32_vec = Type_class.bin_float32_vec let bin_writer_float32_vec = Type_class.bin_writer_float32_vec let bin_write_float32_vec_ = Unsafe_write_c.bin_write_float32_vec let bin_write_float32_vec = Write_ml.bin_write_float32_vec let bin_reader_float32_vec = Type_class.bin_reader_float32_vec let bin_read_float32_vec = Read_ml.bin_read_float32_vec let bin_read_float32_vec_ = Unsafe_read_c.bin_read_float32_vec let bin_read_float32_vec__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "float32_vec" let bin_float64_vec = Type_class.bin_float64_vec let bin_writer_float64_vec = Type_class.bin_writer_float64_vec let bin_write_float64_vec_ = Unsafe_write_c.bin_write_float64_vec let bin_write_float64_vec = Write_ml.bin_write_float64_vec let bin_reader_float64_vec = Type_class.bin_reader_float64_vec let bin_read_float64_vec = Read_ml.bin_read_float64_vec let bin_read_float64_vec_ = Unsafe_read_c.bin_read_float64_vec let bin_read_float64_vec__ _sptr_ptr _eptr _vint = Unsafe_read_c.raise_variant_wrong_type "float64_vec" bin_prot-109.30.00/lib/type_class.ml000066400000000000000000000151021216015522300171020ustar00rootroot00000000000000(* Tp_class: sizers, writers, and readers in records *) type 'a writer = { size : 'a Size.sizer; write : 'a Write_ml.writer; unsafe_write : 'a Unsafe_write_c.writer; } type 'a reader = { read : 'a Read_ml.reader; unsafe_read : 'a Unsafe_read_c.reader; unsafe_vtag_read : (int -> 'a) Unsafe_read_c.reader; } type 'a t = { writer : 'a writer; reader : 'a reader; } type 'a writer0 = 'a writer type 'a reader0 = 'a reader type 'a t0 = 'a t module S1 = struct type ('a, 'b) writer = 'a writer0 -> 'b writer0 type ('a, 'b) reader = 'a reader0 -> 'b reader0 type ('a, 'b) t = 'a t0 -> 'b t0 end module S2 = struct type ('a, 'b, 'c) writer = 'a writer0 -> ('b, 'c) S1.writer type ('a, 'b, 'c) reader = 'a reader0 -> ('b, 'c) S1.reader type ('a, 'b, 'c) t = 'a t0 -> ('b, 'c) S1.t end module S3 = struct type ('a, 'b, 'c, 'd) writer = 'a writer0 -> ('b, 'c, 'd) S2.writer type ('a, 'b, 'c, 'd) reader = 'a reader0 -> ('b, 'c, 'd) S2.reader type ('a, 'b, 'c, 'd) t = 'a t0 -> ('b, 'c, 'd) S2.t end #define MK_BASE(NAME) \ let bin_writer_##NAME = \ { \ size = Size.bin_size_##NAME; \ write = Write_ml.bin_write_##NAME; \ unsafe_write = Unsafe_write_c.bin_write_##NAME; \ } \ let bin_reader_##NAME = \ { \ read = Read_ml.bin_read_##NAME; \ unsafe_read = Unsafe_read_c.bin_read_##NAME; \ unsafe_vtag_read = fun _sptr_ptr _eptr _vint -> \ Unsafe_read_c.raise_variant_wrong_type \ "NAME"; \ } \ let bin_##NAME = \ { \ writer = bin_writer_##NAME; \ reader = bin_reader_##NAME; \ } MK_BASE(unit) MK_BASE(bool) MK_BASE(string) MK_BASE(char) MK_BASE(int) MK_BASE(float) MK_BASE(int32) MK_BASE(int64) MK_BASE(nativeint) MK_BASE(nat0) #define MK_WRITER_BASE1(NAME) \ let bin_writer_##NAME bin_writer_el = \ { \ size = (fun v -> Size.bin_size_##NAME bin_writer_el.size v); \ write = (fun buf ~pos v -> \ Write_ml.bin_write_##NAME bin_writer_el.write buf ~pos v); \ unsafe_write = (fun sptr eptr v -> \ Unsafe_write_c.bin_write_##NAME \ bin_writer_el.unsafe_write sptr eptr v); \ } #define MK_BASE1(NAME) \ MK_WRITER_BASE1(NAME) \ let bin_reader_##NAME bin_reader_el = \ { \ read = (fun buf ~pos_ref -> \ Read_ml.bin_read_##NAME bin_reader_el.read buf ~pos_ref); \ unsafe_read = (fun sptr_ptr eptr -> \ Unsafe_read_c.bin_read_##NAME \ bin_reader_el.unsafe_read sptr_ptr eptr); \ unsafe_vtag_read = (fun _sptr_ptr _eptr _vint -> \ Unsafe_read_c.raise_variant_wrong_type "NAME"); \ } \ let bin_##NAME bin_el = \ { \ writer = bin_writer_##NAME bin_el.writer; \ reader = bin_reader_##NAME bin_el.reader; \ } #define MK_BASE2(NAME) \ let bin_writer_##NAME bin_writer_el1 bin_writer_el2 = \ { \ size = (fun v -> \ Size.bin_size_##NAME bin_writer_el1.size bin_writer_el2.size v); \ write = (fun buf ~pos v -> \ Write_ml.bin_write_##NAME \ bin_writer_el1.write bin_writer_el2.write buf ~pos v); \ unsafe_write = (fun sptr eptr v -> \ Unsafe_write_c.bin_write_##NAME \ bin_writer_el1.unsafe_write bin_writer_el2.unsafe_write \ sptr eptr v); \ } \ let bin_reader_##NAME bin_reader_el1 bin_reader_el2 = \ { \ read = (fun buf ~pos_ref -> \ Read_ml.bin_read_##NAME \ bin_reader_el1.read bin_reader_el2.read buf ~pos_ref); \ unsafe_read = (fun sptr_ptr eptr -> \ Unsafe_read_c.bin_read_##NAME \ bin_reader_el1.unsafe_read bin_reader_el2.unsafe_read \ sptr_ptr eptr); \ unsafe_vtag_read = (fun _sptr_ptr _eptr _vint -> \ Unsafe_read_c.raise_variant_wrong_type "NAME"); \ } \ let bin_##NAME bin_el1 bin_el2 = \ { \ writer = bin_writer_##NAME bin_el1.writer bin_el2.writer; \ reader = bin_reader_##NAME bin_el1.reader bin_el2.reader; \ } #define MK_BASE3(NAME) \ let bin_writer_##NAME bin_writer_el1 bin_writer_el2 bin_writer_el3 = \ { \ size = (fun v -> \ Size.bin_size_##NAME \ bin_writer_el1.size bin_writer_el2.size bin_writer_el3.size v); \ write = (fun buf ~pos v -> \ Write_ml.bin_write_##NAME \ bin_writer_el1.write bin_writer_el2.write \ bin_writer_el3.write buf ~pos v); \ unsafe_write = (fun sptr eptr v -> \ Unsafe_write_c.bin_write_##NAME \ bin_writer_el1.unsafe_write bin_writer_el2.unsafe_write \ bin_writer_el3.unsafe_write sptr eptr v); \ } \ let bin_reader_##NAME bin_reader_el1 bin_reader_el2 bin_reader_el3 = \ { \ read = (fun buf ~pos_ref -> \ Read_ml.bin_read_##NAME \ bin_reader_el1.read bin_reader_el2.read \ bin_reader_el3.read buf ~pos_ref); \ unsafe_read = (fun sptr_ptr eptr -> \ Unsafe_read_c.bin_read_##NAME \ bin_reader_el1.unsafe_read bin_reader_el2.unsafe_read \ bin_reader_el3.unsafe_read sptr_ptr eptr); \ unsafe_vtag_read = (fun _sptr_ptr _eptr _vint -> \ Unsafe_read_c.raise_variant_wrong_type "NAME"); \ } \ let bin_##NAME bin_el1 bin_el2 bin_el3 = \ { \ writer = \ bin_writer_##NAME bin_el1.writer bin_el2.writer bin_el3.writer; \ reader = \ bin_reader_##NAME bin_el1.reader bin_el2.reader bin_el3.reader; \ } MK_BASE1(ref) MK_BASE1(lazy) MK_BASE1(option) MK_BASE2(pair) MK_BASE3(triple) MK_BASE1(list) MK_BASE1(array) MK_BASE2(hashtbl) MK_BASE(float32_vec) MK_BASE(float64_vec) MK_BASE(vec) MK_BASE(float32_mat) MK_BASE(float64_mat) MK_BASE(mat) MK_BASE(bigstring) MK_BASE(float_array) MK_BASE(variant_tag) MK_BASE(int_8bit) MK_BASE(int_16bit) MK_BASE(int_32bit) MK_BASE(int_64bit) MK_BASE(int64_bits) MK_BASE(network16_int) MK_BASE(network32_int) MK_BASE(network32_int32) MK_BASE(network64_int) MK_BASE(network64_int64) MK_WRITER_BASE1(array_no_length) (* Conversion of binable types *) let cnv_writer cnv tp_class = { size = (fun v -> tp_class.size (cnv v)); write = (fun buf ~pos v -> tp_class.write buf ~pos (cnv v)); unsafe_write = (fun sptr eptr v -> tp_class.unsafe_write sptr eptr (cnv v)); } let cnv_reader cnv tp_class = { read = (fun buf ~pos_ref -> cnv (tp_class.read buf ~pos_ref)); unsafe_read = (fun sptr_ptr eptr -> cnv (tp_class.unsafe_read sptr_ptr eptr)); unsafe_vtag_read = (fun sptr_ptr eptr vtag -> cnv (tp_class.unsafe_vtag_read sptr_ptr eptr vtag)); } let cnv for_writer for_reader tp_class = { writer = cnv_writer for_writer tp_class.writer; reader = cnv_reader for_reader tp_class.reader; } bin_prot-109.30.00/lib/type_class.mli000066400000000000000000000063071216015522300172620ustar00rootroot00000000000000(** Sizers, writers, and readers in records *) open Common type 'a writer = { size : 'a Size.sizer; write : 'a Write_ml.writer; unsafe_write : 'a Unsafe_write_c.writer; } type 'a reader = { read : 'a Read_ml.reader; unsafe_read : 'a Unsafe_read_c.reader; unsafe_vtag_read : (int -> 'a) Unsafe_read_c.reader; } type 'a t = { writer : 'a writer; reader : 'a reader; } type 'a writer0 = 'a writer type 'a reader0 = 'a reader type 'a t0 = 'a t module S1 : sig type ('a, 'b) writer = 'a writer0 -> 'b writer0 type ('a, 'b) reader = 'a reader0 -> 'b reader0 type ('a, 'b) t = 'a t0 -> 'b t0 end module S2 : sig type ('a, 'b, 'c) writer = 'a writer0 -> ('b, 'c) S1.writer type ('a, 'b, 'c) reader = 'a reader0 -> ('b, 'c) S1.reader type ('a, 'b, 'c) t = 'a t0 -> ('b, 'c) S1.t end module S3 : sig type ('a, 'b, 'c, 'd) writer = 'a writer0 -> ('b, 'c, 'd) S2.writer type ('a, 'b, 'c, 'd) reader = 'a reader0 -> ('b, 'c, 'd) S2.reader type ('a, 'b, 'c, 'd) t = 'a t0 -> ('b, 'c, 'd) S2.t end #define MK_BASE_TP(NAME, TP) \ val bin_writer_##NAME : TP writer \ val bin_reader_##NAME : TP reader \ val bin_##NAME : TP t #define MK_BASE(NAME) MK_BASE_TP(NAME, NAME) #define MK_BASE1_TP(NAME, TP) \ val bin_writer_##NAME : ('a, 'a TP) S1.writer \ val bin_reader_##NAME : ('a, 'a TP) S1.reader \ val bin_##NAME : ('a, 'a TP) S1.t #define MK_BASE1(NAME) MK_BASE1_TP(NAME, NAME) #define MK_BASE2_TP(NAME, TP) \ val bin_writer_##NAME : ('a, 'b, ('a, 'b) TP) S2.writer \ val bin_reader_##NAME : ('a, 'b, ('a, 'b) TP) S2.reader \ val bin_##NAME : ('a, 'b, ('a, 'b) TP) S2.t #define MK_BASE2(NAME) MK_BASE2_TP(NAME, NAME) MK_BASE(unit) MK_BASE(bool) MK_BASE(string) MK_BASE(char) MK_BASE(int) MK_BASE(float) MK_BASE(int32) MK_BASE(int64) MK_BASE(nativeint) MK_BASE_TP(nat0, Nat0.t) MK_BASE1(ref) MK_BASE1_TP(lazy, lazy_t) MK_BASE1(option) val bin_writer_pair : ('a, 'b, 'a * 'b) S2.writer val bin_reader_pair : ('a, 'b, 'a * 'b) S2.reader val bin_pair : ('a, 'b, 'a * 'b) S2.t val bin_writer_triple : ('a, 'b, 'c, 'a * 'b * 'c) S3.writer val bin_reader_triple : ('a, 'b, 'c, 'a * 'b * 'c) S3.reader val bin_triple : ('a, 'b, 'c, 'a * 'b * 'c) S3.t MK_BASE1(list) MK_BASE1(array) MK_BASE2_TP(hashtbl, Hashtbl.t) MK_BASE_TP(float32_vec, vec32) MK_BASE_TP(float64_vec, vec64) MK_BASE(vec) MK_BASE_TP(float32_mat, mat32) MK_BASE_TP(float64_mat, mat64) MK_BASE(mat) MK_BASE_TP(bigstring, buf) val bin_writer_float_array : float array writer val bin_reader_float_array : float array reader val bin_float_array : float array t val bin_writer_variant_tag : [> ] writer val bin_reader_variant_tag : [> ] reader val bin_variant_tag : [> ] t MK_BASE_TP(int_8bit, int) MK_BASE_TP(int_16bit, int) MK_BASE_TP(int_32bit, int) MK_BASE_TP(int_64bit, int) MK_BASE_TP(int64_bits, int64) MK_BASE_TP(network16_int, int) MK_BASE_TP(network32_int, int) MK_BASE_TP(network32_int32, int32) MK_BASE_TP(network64_int, int) MK_BASE_TP(network64_int64, int64) val bin_writer_array_no_length : ('a, 'a array) S1.writer (** Conversion of binable types *) val cnv_writer : ('a -> 'b) -> 'b writer -> 'a writer val cnv_reader : ('b -> 'a) -> 'b reader -> 'a reader val cnv : ('a -> 'b) -> ('b -> 'a) -> 'b t -> 'a t bin_prot-109.30.00/lib/unsafe_common.ml000066400000000000000000000031171216015522300175700ustar00rootroot00000000000000(* Unsafe_common: functions common to unsafe binary protocol conversion. *) open Common open Bigarray type sptr type eptr type sptr_ptr external get_sptr : buf -> pos : pos -> sptr = "get_buf_ptr_stub" "noalloc" external get_eptr : buf -> pos : pos -> eptr = "get_buf_ptr_stub" "noalloc" external shift_sptr : sptr -> int -> sptr = "shift_sptr_stub" "noalloc" external get_eptr_from_sptr_ptr : sptr_ptr -> pos : pos -> eptr = "get_eptr_from_sptr_ptr" "noalloc" external get_buf_pos : start : sptr -> cur : sptr -> pos = "get_buf_pos_stub" "noalloc" external get_safe_buf_pos : buf -> start : sptr -> cur : sptr -> pos = "get_safe_buf_pos_stub" "noalloc" external alloc_sptr_ptr : buf -> pos : pos -> sptr_ptr = "alloc_sptr_ptr_stub" "noalloc" external dealloc_sptr_ptr : buf -> sptr_ptr -> pos = "dealloc_sptr_ptr_stub" "noalloc" external get_sptr_ptr : sptr_ptr -> buf -> pos = "get_sptr_ptr_stub" "noalloc" external set_sptr_ptr : sptr_ptr -> buf -> pos : pos -> unit = "set_sptr_ptr_stub" "noalloc" external get_sptr_ptr_sptr : sptr_ptr -> sptr = "get_sptr_ptr_sptr_stub" "noalloc" external set_sptr_ptr_sptr : sptr_ptr -> sptr -> unit = "set_sptr_ptr_sptr_stub" "noalloc" external get_ptr_string : sptr -> eptr -> string = "get_ptr_string_stub" let get_read_init buf ~pos_ref = let start_pos = !pos_ref in if start_pos < 0 then array_bound_error () else let buf_len = Array1.dim buf in if start_pos > buf_len then raise Buffer_short else let sptr_ptr = alloc_sptr_ptr buf ~pos:start_pos in let eptr = get_eptr buf ~pos:buf_len in sptr_ptr, eptr bin_prot-109.30.00/lib/unsafe_common.mli000066400000000000000000000071271216015522300177460ustar00rootroot00000000000000(** Functions common to unsafe binary protocol conversion. *) (** NOTE: these functions are not supposed to be called by the casual user. They are required by automatically generated code, or if a developer really needs to get down and dirty for performance reasons. USE WITH CAUTION! *) open Common (** Type of start pointers *) type sptr (** Type of end pointers *) type eptr (** Type of pointers to start pointers *) type sptr_ptr external get_sptr : buf -> pos : pos -> sptr = "get_buf_ptr_stub" "noalloc" (** [get_sptr buf ~pos] @return a start pointer given buffer [buf] and start position [pos]. *) external get_eptr : buf -> pos : pos -> eptr = "get_buf_ptr_stub" "noalloc" (** [get_eptr buf ~pos] @return an end pointer given buffer [buf] and end position [pos]. *) external shift_sptr : sptr -> int -> sptr = "shift_sptr_stub" "noalloc" (** [shift_sptr sptr n] @return a start pointer by shifting [sptr] by [n] characters. *) external get_eptr_from_sptr_ptr : sptr_ptr -> pos : pos -> eptr = "get_eptr_from_sptr_ptr" "noalloc" (** [get_eptr_from_sptr_ptr sptr_ptr ~pos] @return an end pointer by obtaining the position [pos] after location [sptr_ptr]. *) external get_buf_pos : start : sptr -> cur : sptr -> pos = "get_buf_pos_stub" "noalloc" (** [get_buf_pos ~start ~cur] @return a buffer position as difference between start pointers [start] and [cur]. *) external get_safe_buf_pos : buf -> start : sptr -> cur : sptr -> pos = "get_safe_buf_pos_stub" "noalloc" (** [get_safe_buf_pos buf ~start ~cur] @return a buffer position as difference between start pointers [start] and [cur]. [buf] is ignored, but prevents the buffer from being reclaimed by the GC, which it needs to until this function gets called. *) external alloc_sptr_ptr : buf -> pos : pos -> sptr_ptr = "alloc_sptr_ptr_stub" "noalloc" (** [alloc_sptr_ptr buf ~pos] allocate a pointer to a start pointer. NOTE: do not forget to deallocate it, otherwise there will be a space leak! NOTE: The "noalloc" attribute is correct, because it indicates there is no OCaml allocation. [alloc_sptr_ptr] only does C allocation. *) external dealloc_sptr_ptr : buf -> sptr_ptr -> pos = "dealloc_sptr_ptr_stub" "noalloc" (** [dealloc_sptr_ptr buf sptr_ptr] deallocate a pointer to a start pointer and return its position. NOTE: do not do this more than once, otherwise the program may crash! *) external get_sptr_ptr : sptr_ptr -> buf -> pos = "get_sptr_ptr_stub" "noalloc" (** [get_sptr_ptr sptr_ptr buf] @return the position in buffer [buf] denoted by the pointer stored in [sptr_ptr]. *) external set_sptr_ptr : sptr_ptr -> buf -> pos : pos -> unit = "set_sptr_ptr_stub" "noalloc" (** [set_sptr_ptr sptr_ptr buf ~pos] sets the pointer in [sptr_ptr] to the location denoted by position [pos] in buffer [buf]. *) external get_sptr_ptr_sptr : sptr_ptr -> sptr = "get_sptr_ptr_sptr_stub" "noalloc" (** [get_sptr_ptr_sptr sptr_ptr] @return the pointer in [sptr_ptr]. *) external set_sptr_ptr_sptr : sptr_ptr -> sptr -> unit = "set_sptr_ptr_sptr_stub" "noalloc" (** [set_sptr_ptr_sptr sptr_ptr sptr] sets the pointer in [sptr_ptr] to [sptr]. *) external get_ptr_string : sptr -> eptr -> string = "get_ptr_string_stub" (** [get_ptr_string sptr_ptr eptr] @return the string in the range from start pointer [sptr] to end pointer [eptr]. *) val get_read_init : buf -> pos_ref : pos ref -> sptr_ptr * eptr (** [get_read_init buf ~pos_ref] @return the [sptr_ptr] denoting the start and the [eptr] denoting the end of buffer [buf]. NOTE: do not forget to deallocate the [sptr_ptr]! *) bin_prot-109.30.00/lib/unsafe_read_c.ml000066400000000000000000000146601216015522300175220ustar00rootroot00000000000000(* Unsafe_read_c: reading values from the binary protocol using unsafe C. *) open Common open Unsafe_common exception Error of ReadError.t let raise_variant_wrong_type type_name = raise (Error (ReadError.Variant_wrong_type type_name)) external init : unit -> unit = "bin_prot_unsafe_read_c_init_stub" let () = let err = Error ReadError.Neg_int8 in Callback.register_exception "Bin_prot.Unsafe_read_c.Error" err; init () type 'a reader = sptr_ptr -> eptr -> 'a type ('a, 'b) reader1 = 'a reader -> 'b reader type ('a, 'b, 'c) reader2 = 'a reader -> ('b, 'c) reader1 type ('a, 'b, 'c, 'd) reader3 = 'a reader -> ('b, 'c, 'd) reader2 external bin_read_unit : sptr_ptr -> eptr -> unit = "read_unit_stub" external bin_read_bool : sptr_ptr -> eptr -> bool = "read_bool_stub" external bin_read_option_bool : sptr_ptr -> eptr -> bool = "read_option_bool_stub" external bin_read_string : sptr_ptr -> eptr -> string = "read_string_stub" external bin_read_char : sptr_ptr -> eptr -> char = "read_char_stub" external bin_read_int : sptr_ptr -> eptr -> int = "read_int_stub" external bin_read_float : sptr_ptr -> eptr -> float = "read_float_stub" external bin_read_int32 : sptr_ptr -> eptr -> int32 = "read_int32_stub" external bin_read_int64 : sptr_ptr -> eptr -> int64 = "read_int64_stub" external bin_read_nativeint : sptr_ptr -> eptr -> nativeint = "read_nativeint_stub" external bin_read_nat0 : sptr_ptr -> eptr -> Nat0.t = "read_nat0_stub" let bin_read_ref bin_read_el sptr_ptr eptr = let el = bin_read_el sptr_ptr eptr in ref el let bin_read_lazy bin_read_el sptr_ptr eptr = let el = bin_read_el sptr_ptr eptr in Lazy.lazy_from_val el let bin_read_option bin_read_el sptr_ptr eptr = if bin_read_option_bool sptr_ptr eptr then let el = bin_read_el sptr_ptr eptr in Some el else None let bin_read_pair bin_read_a bin_read_b sptr_ptr eptr = let a = bin_read_a sptr_ptr eptr in let b = bin_read_b sptr_ptr eptr in a, b let bin_read_triple bin_read_a bin_read_b bin_read_c sptr_ptr eptr = let a = bin_read_a sptr_ptr eptr in let b = bin_read_b sptr_ptr eptr in let c = bin_read_c sptr_ptr eptr in a, b, c let bin_read_n_rev_list bin_read_el sptr_ptr eptr len = let rec loop n acc = if n = 0 then acc else loop (n - 1) (bin_read_el sptr_ptr eptr :: acc) in loop len [] let bin_read_list bin_read_el sptr_ptr eptr = let len = (bin_read_nat0 sptr_ptr eptr :> int) in let rev_lst = bin_read_n_rev_list bin_read_el sptr_ptr eptr len in List.rev rev_lst #ifndef ARCH_SIXTYFOUR let dummy_float_buf = create_buf 8 let () = ignore (Write_ml.bin_write_float dummy_float_buf ~pos:0 3.1) let dummy_float_buf_eptr = get_eptr dummy_float_buf ~pos:0 let max_array_length_2 = Sys.max_array_length / 2 #endif let set_and_raise sptr_ptr sptr err = set_sptr_ptr_sptr sptr_ptr sptr; raise (Error err) let bin_read_array bin_read_el sptr_ptr eptr = let sptr = get_sptr_ptr_sptr sptr_ptr in let len = (bin_read_nat0 sptr_ptr eptr :> int) in if len = 0 then [||] else ( #ifdef ARCH_SIXTYFOUR if len > Sys.max_array_length then set_and_raise sptr_ptr sptr ReadError.Array_too_long; #else if len > max_array_length_2 then ( let dummy_sptr_ptr = alloc_sptr_ptr dummy_float_buf ~pos:0 in let maybe_float = try let el = bin_read_el dummy_sptr_ptr dummy_float_buf_eptr in Some el with _ -> None in ignore (dealloc_sptr_ptr dummy_float_buf dummy_sptr_ptr); match maybe_float with | None -> if len > Sys.max_array_length then set_and_raise sptr_ptr sptr ReadError.Array_too_long | Some el -> if Obj.tag (Obj.repr el) = Obj.double_tag || len > Sys.max_array_length then set_and_raise sptr_ptr sptr ReadError.Array_too_long ); #endif let first = bin_read_el sptr_ptr eptr in let res = Array.create len first in for i = 1 to len - 1 do let el = bin_read_el sptr_ptr eptr in Array.unsafe_set res i el done; res) let bin_read_hashtbl bin_read_key bin_read_val sptr_ptr eptr = let len = (bin_read_nat0 sptr_ptr eptr :> int) in let read_kv_pair = bin_read_pair bin_read_key bin_read_val in let els = bin_read_n_rev_list read_kv_pair sptr_ptr eptr len in copy_htbl_list (Hashtbl.create len) els external bin_read_float32_vec : sptr_ptr -> eptr -> vec32 = "read_float32_vec_stub" external bin_read_float64_vec : sptr_ptr -> eptr -> vec64 = "read_float64_vec_stub" external bin_read_vec : sptr_ptr -> eptr -> vec = "read_float64_vec_stub" external bin_read_float32_mat : sptr_ptr -> eptr -> mat32 = "read_float32_mat_stub" external bin_read_float64_mat : sptr_ptr -> eptr -> mat64 = "read_float64_mat_stub" external bin_read_mat : sptr_ptr -> eptr -> mat = "read_float64_mat_stub" external bin_read_bigstring : sptr_ptr -> eptr -> buf = "read_bigstring_stub" external bin_read_float_array : sptr_ptr -> eptr -> float array = "read_float_array_stub" external bin_read_variant_int : sptr_ptr -> eptr -> int = "read_variant_tag_stub" external bin_read_variant_tag : sptr_ptr -> eptr -> [> ] = "read_variant_tag_stub" external bin_read_raw_string : sptr_ptr -> eptr -> string -> pos : int -> len : int -> unit = "read_raw_string_stub" let bin_read_raw_string sptr_ptr eptr str ~pos ~len = if pos < 0 then failwith "Bin_prot.unsafe_read_c.bin_read_raw_string: pos < 0" else if len < 0 then failwith "Bin_prot.unsafe_read_c.bin_read_raw_string: len < 0" else if pos + len > String.length str then failwith "Bin_prot.unsafe_read_c.bin_read_raw_string: pos + len > str_len" else bin_read_raw_string sptr_ptr eptr str ~pos ~len external bin_read_int_8bit : sptr_ptr -> eptr -> int = "read_char_stub" external bin_read_int_16bit : sptr_ptr -> eptr -> int = "read_int_16bit_stub" external bin_read_int_32bit : sptr_ptr -> eptr -> int = "read_int_32bit_stub" external bin_read_int_64bit : sptr_ptr -> eptr -> int = "read_int_64bit_stub" external bin_read_int64_bits : sptr_ptr -> eptr -> int64 = "read_int64_bits_stub" external bin_read_network16_int : sptr_ptr -> eptr -> int = "read_network16_int_stub" external bin_read_network32_int : sptr_ptr -> eptr -> int = "read_network32_int_stub" external bin_read_network32_int32 : sptr_ptr -> eptr -> int32 = "read_network32_int32_stub" external bin_read_network64_int : sptr_ptr -> eptr -> int = "read_network64_int_stub" external bin_read_network64_int64 : sptr_ptr -> eptr -> int64 = "read_network64_int64_stub" bin_prot-109.30.00/lib/unsafe_read_c.mli000066400000000000000000000045451216015522300176740ustar00rootroot00000000000000(** Reading values from the binary protocol using unsafe C. *) open Common open Unsafe_common exception Error of ReadError.t val raise_variant_wrong_type : string -> 'a (** [raise_variant_wrong_type type_name] @raise Error (Common.ReadError.VariantWrongType type_name). *) type 'a reader = sptr_ptr -> eptr -> 'a (** Type of unsafe reader functions for the binary protocol. They take a pointer to a source pointer to start reading and an end pointer designating the end of the buffer, and return the unmarshalled value. The pointer to the next buffer position after reading in the value will be stored in the pointer to the source pointer. *) type ('a, 'b) reader1 = 'a reader -> 'b reader type ('a, 'b, 'c) reader2 = 'a reader -> ('b, 'c) reader1 type ('a, 'b, 'c, 'd) reader3 = 'a reader -> ('b, 'c, 'd) reader2 val bin_read_unit : unit reader val bin_read_bool : bool reader val bin_read_string : string reader val bin_read_char : char reader val bin_read_int : int reader val bin_read_float : float reader val bin_read_int32 : int32 reader val bin_read_int64 : int64 reader val bin_read_nativeint : nativeint reader val bin_read_nat0 : Nat0.t reader val bin_read_ref : ('a, 'a ref) reader1 val bin_read_lazy : ('a, 'a lazy_t) reader1 val bin_read_option : ('a, 'a option) reader1 val bin_read_pair : ('a, 'b, 'a * 'b) reader2 val bin_read_triple : ('a, 'b, 'c, 'a * 'b * 'c) reader3 val bin_read_list : ('a, 'a list) reader1 val bin_read_array : ('a, 'a array) reader1 val bin_read_hashtbl : ('a, 'b, ('a, 'b) Hashtbl.t) reader2 val bin_read_float32_vec : vec32 reader val bin_read_float64_vec : vec64 reader val bin_read_vec : vec reader val bin_read_float32_mat : mat32 reader val bin_read_float64_mat : mat64 reader val bin_read_mat : mat reader val bin_read_bigstring : buf reader val bin_read_float_array : float array reader val bin_read_variant_int : int reader val bin_read_variant_tag : [> ] reader val bin_read_raw_string : (string -> pos : int -> len : int -> unit) reader val bin_read_int_8bit : int reader val bin_read_int_16bit : int reader val bin_read_int_32bit : int reader val bin_read_int_64bit : int reader val bin_read_int64_bits : int64 reader val bin_read_network16_int : int reader val bin_read_network32_int : int reader val bin_read_network32_int32 : int32 reader val bin_read_network64_int : int reader val bin_read_network64_int64 : int64 reader bin_prot-109.30.00/lib/unsafe_write_c.ml000066400000000000000000000126761216015522300177460ustar00rootroot00000000000000(* Unsafe_write_c: writing values to the binary protocol using unsafe C. *) open Common open Unsafe_common type 'a writer = sptr -> eptr -> 'a -> sptr type ('a, 'b) writer1 = 'a writer -> 'b writer type ('a, 'b, 'c) writer2 = 'a writer -> ('b, 'c) writer1 type ('a, 'b, 'c, 'd) writer3 = 'a writer -> ('b, 'c, 'd) writer2 external bin_write_unit : sptr -> eptr -> unit -> sptr = "write_small_int_stub" external bin_write_bool : sptr -> eptr -> bool -> sptr = "write_small_int_stub" external bin_write_string : sptr -> eptr -> string -> sptr = "write_string_stub" external bin_write_char : sptr -> eptr -> char -> sptr = "write_small_int_stub" external bin_write_int : sptr -> eptr -> int -> sptr = "write_int_stub" external bin_write_float : sptr -> eptr -> float -> sptr = "write_float_stub" external bin_write_int32 : sptr -> eptr -> int32 -> sptr = "write_int32_stub" external bin_write_int64 : sptr -> eptr -> int64 -> sptr = "write_int64_stub" external bin_write_nativeint : sptr -> eptr -> nativeint -> sptr = "write_nativeint_stub" external bin_write_nat0 : sptr -> eptr -> Nat0.t -> sptr = "write_nat0_stub" let bin_write_ref bin_write_el sptr eptr r = bin_write_el sptr eptr !r let bin_write_lazy bin_write_el sptr eptr lv = let v = Lazy.force lv in bin_write_el sptr eptr v let bin_write_option bin_write_el sptr eptr = function | None -> bin_write_bool sptr eptr false | Some v -> let new_sptr = bin_write_bool sptr eptr true in bin_write_el new_sptr eptr v let bin_write_pair bin_write_a bin_write_b sptr eptr (a, b) = let new_sptr = bin_write_a sptr eptr a in bin_write_b new_sptr eptr b let bin_write_triple bin_write_a bin_write_b bin_write_c sptr eptr (a, b, c) = let new_sptr1 = bin_write_a sptr eptr a in let new_sptr2 = bin_write_b new_sptr1 eptr b in bin_write_c new_sptr2 eptr c let bin_write_list bin_write_el sptr eptr lst = let rec loop els_sptr = function | [] -> els_sptr | h :: t -> let new_els_sptr = bin_write_el els_sptr eptr h in loop new_els_sptr t in let plen = Nat0.unsafe_of_int (List.length lst) in let els_sptr = bin_write_nat0 sptr eptr plen in loop els_sptr lst let bin_write_array_loop bin_write_el sptr eptr ar n = let els_sptr_ref = ref sptr in for i = 0 to n - 1 do let el = Array.unsafe_get ar i in let new_els_sptr = bin_write_el !els_sptr_ref eptr el in els_sptr_ref := new_els_sptr done; !els_sptr_ref let bin_write_array bin_write_el sptr eptr ar = let n = Array.length ar in let pn = Nat0.unsafe_of_int n in let els_sptr = bin_write_nat0 sptr eptr pn in bin_write_array_loop bin_write_el els_sptr eptr ar n let bin_write_hashtbl bin_write_key bin_write_val sptr eptr htbl = let len = Hashtbl.length htbl in let plen = Nat0.unsafe_of_int len in let els_sptr = bin_write_nat0 sptr eptr plen in let cnt_ref = ref 0 in let coll_htbl k v els_sptr = incr cnt_ref; let new_els_sptr = bin_write_key els_sptr eptr k in bin_write_val new_els_sptr eptr v in let res_sptr = Hashtbl.fold coll_htbl htbl els_sptr in if !cnt_ref <> len then raise_concurrent_modification "bin_write_hashtbl"; res_sptr external bin_write_float32_vec : sptr -> eptr -> vec32 -> sptr = "write_float32_vec_stub" external bin_write_float64_vec : sptr -> eptr -> vec64 -> sptr = "write_float64_vec_stub" external bin_write_vec : sptr -> eptr -> vec -> sptr = "write_float64_vec_stub" external bin_write_float32_mat : sptr -> eptr -> mat32 -> sptr = "write_float32_mat_stub" external bin_write_float64_mat : sptr -> eptr -> mat64 -> sptr = "write_float64_mat_stub" external bin_write_mat : sptr -> eptr -> mat -> sptr = "write_float64_mat_stub" external bin_write_bigstring : sptr -> eptr -> buf -> sptr = "write_bigstring_stub" external bin_write_float_array : sptr -> eptr -> float array -> sptr = "write_float_array_stub" external bin_write_variant_tag : sptr -> eptr -> [> ] -> sptr = "write_variant_tag_stub" external bin_write_raw_string : sptr -> eptr -> string -> pos : int -> len : int -> sptr = "write_raw_string_stub" let bin_write_raw_string sptr eptr str ~pos ~len = if pos < 0 then failwith "Bin_prot.unsafe_write_c.bin_write_raw_string: pos < 0" else if len < 0 then failwith "Bin_prot.unsafe_write_c.bin_write_raw_string: len < 0" else if pos + len > String.length str then failwith "Bin_prot.unsafe_write_c.bin_write_raw_string: pos + len > str_len" else bin_write_raw_string sptr eptr str ~pos ~len external bin_write_int_8bit : sptr -> eptr -> int -> sptr = "write_int_8bit_stub" external bin_write_int_16bit : sptr -> eptr -> int -> sptr = "write_int_16bit_stub" external bin_write_int_32bit : sptr -> eptr -> int -> sptr = "write_int_32bit_stub" external bin_write_int_64bit : sptr -> eptr -> int -> sptr = "write_int_64bit_stub" external bin_write_int64_bits : sptr -> eptr -> int64 -> sptr = "write_int64_bits_stub" external bin_write_network16_int : sptr -> eptr -> int -> sptr = "write_network16_int_stub" external bin_write_network32_int : sptr -> eptr -> int -> sptr = "write_network32_int_stub" external bin_write_network32_int32 : sptr -> eptr -> int32 -> sptr = "write_network32_int32_stub" external bin_write_network64_int : sptr -> eptr -> int -> sptr = "write_network64_int_stub" external bin_write_network64_int64 : sptr -> eptr -> int64 -> sptr = "write_network64_int64_stub" let bin_write_array_no_length bin_write_el sptr eptr ar = bin_write_array_loop bin_write_el sptr eptr ar (Array.length ar) bin_prot-109.30.00/lib/unsafe_write_c.mli000066400000000000000000000067441216015522300201160ustar00rootroot00000000000000(** Writing values to the binary protocol using unsafe C. *) open Common open Unsafe_common type 'a writer = sptr -> eptr -> 'a -> sptr (** Type of unsafe writer functions for the binary protocol. They take a start pointer for writing, an end pointer designating the end of the buffer and the value to be written, and return the start pointer to the next write position. *) type ('a, 'b) writer1 = 'a writer -> 'b writer type ('a, 'b, 'c) writer2 = 'a writer -> ('b, 'c) writer1 type ('a, 'b, 'c, 'd) writer3 = 'a writer -> ('b, 'c, 'd) writer2 val bin_write_unit : unit writer val bin_write_bool : bool writer val bin_write_string : string writer val bin_write_char : char writer val bin_write_int : int writer val bin_write_float : float writer val bin_write_int32 : int32 writer val bin_write_int64 : int64 writer val bin_write_nativeint : nativeint writer val bin_write_nat0 : Nat0.t writer val bin_write_ref : ('a, 'a ref) writer1 val bin_write_lazy : ('a, 'a lazy_t) writer1 val bin_write_option : ('a, 'a option) writer1 val bin_write_pair : ('a, 'b, 'a * 'b) writer2 val bin_write_triple : ('a, 'b, 'c, 'a * 'b * 'c) writer3 val bin_write_list : ('a, 'a list) writer1 val bin_write_array : ('a, 'a array) writer1 val bin_write_hashtbl : ('a, 'b, ('a, 'b) Hashtbl.t) writer2 val bin_write_float32_vec : vec32 writer val bin_write_float64_vec : vec64 writer val bin_write_vec : vec writer val bin_write_float32_mat : mat32 writer val bin_write_float64_mat : mat64 writer val bin_write_mat : mat writer val bin_write_bigstring : buf writer val bin_write_float_array : float array writer val bin_write_variant_tag : [> ] writer (** [bin_write_variant_tag] writes out the exact bit representation of the variant tag of the given value (= 32 bits). *) val bin_write_raw_string : sptr -> eptr -> string -> pos : int -> len : int -> sptr val bin_write_int_8bit : int writer (** [bin_write_int_8bit] writes out the exact bit representation of the given [int] value using the lower 8 bits. *) val bin_write_int_16bit : int writer (** [bin_write_int_16bit] writes out the exact bit representation of the given [int] value using the lower 16 bits. *) val bin_write_int_32bit : int writer (** [bin_write_int_32bit] writes out the exact bit representation of the given [int] value using the lower 32 bits. *) val bin_write_int_64bit : int writer (** [bin_write_int_64bit] writes out the exact bit representation of the given [int] value using all 64 bits. *) val bin_write_int64_bits : int64 writer (** [bin_write_int64_bits] writes out the exact bit representation of the given [int64] value. *) val bin_write_network16_int : int writer (** [bin_write_network16_int] writes out an integer in 16bit network byte order (= big-endian). *) val bin_write_network32_int : int writer (** [bin_write_network32_int] writes out an integer in 32bit network byte order (= big-endian). *) val bin_write_network32_int32 : int32 writer (** [bin_write_network32_int32] writes out a 32bit integer in 32bit network byte order (= big-endian). *) val bin_write_network64_int : int writer (** [bin_write_network64_int] writes out an integer in 64bit network byte order (= big-endian). *) val bin_write_network64_int64 : int64 writer (** [bin_write_network64_int64] writes out a 64bit integer in 64bit network byte order (= big-endian). *) val bin_write_array_no_length : ('a, 'a array) writer1 (** [bin_write_array_no_length] writes out all values in the given array without writing out its length. *) bin_prot-109.30.00/lib/utils.ml000066400000000000000000000400571216015522300161030ustar00rootroot00000000000000(* Utils: utility functions for user convenience *) open Common open Read_ml open Write_ml open Size open Type_class let header_len = 8 let bin_dump ?(header = false) writer v = let buf, pos, pos_len = let v_len = writer.size v in if header then let tot_len = v_len + header_len in let buf = create_buf tot_len in let pos = bin_write_int64_bits buf ~pos:0 (Int64.of_int v_len) in buf, pos, pos + v_len else let buf = create_buf v_len in buf, 0, v_len in let pos = writer.write buf ~pos v in if pos = pos_len then buf else failwith "Bin_prot.Utils.bin_dump: size changed during writing" (* Reading from streams *) let bin_read_stream ?max_size ~read reader = let buf = create_buf header_len in read buf ~pos:0 ~len:header_len; let pos_ref = ref 0 in let len64 = bin_read_int64_bits buf ~pos_ref in let len = Int64.to_int len64 in if Int64.of_int len <> len64 then failwith ( Printf.sprintf "Bin_prot.Utils.bin_read_stream: size header overflow: %Ld" len64) else match max_size with | Some max_size when len > max_size -> failwith ( Printf.sprintf "Bin_prot.Utils.bin_read_stream: size exceeds max_size: %d > %d" len max_size) | _ -> let buf = if len > header_len then create_buf len else buf in read buf ~pos:0 ~len; pos_ref := 0; let res = reader.read buf ~pos_ref in if !pos_ref = len then res else let msg = Printf.sprintf "Bin_prot.Utils.bin_read_stream: \ protocol lied about length of value: expected %d, received %d" len !pos_ref in failwith msg (* Conversion of binable types *) module type Make_binable_spec = sig module Binable : Binable.S type t val to_binable : t -> Binable.t val of_binable : Binable.t -> t end module Make_binable (S : Make_binable_spec) = struct module B = S.Binable let bin_size_t t = B.bin_size_t (S.to_binable t) let bin_write_t buf ~pos t = B.bin_write_t buf ~pos (S.to_binable t) let bin_write_t_ sptr eptr t = B.bin_write_t_ sptr eptr (S.to_binable t) let bin_read_t buf ~pos_ref = S.of_binable (B.bin_read_t buf ~pos_ref) let bin_read_t_ sptr_ptr eptr = S.of_binable (B.bin_read_t_ sptr_ptr eptr) let bin_read_t__ sptr_ptr eptr n = S.of_binable (B.bin_read_t__ sptr_ptr eptr n) let bin_writer_t = { size = bin_size_t; write = bin_write_t; unsafe_write = bin_write_t_; } let bin_reader_t = { read = bin_read_t; unsafe_read = bin_read_t_; unsafe_vtag_read = bin_read_t__; } let bin_t = { writer = bin_writer_t; reader = bin_reader_t; } end module type Make_binable1_spec = sig module Binable : Binable.S1 type 'a t val to_binable : 'a t -> 'a Binable.t val of_binable : 'a Binable.t -> 'a t end module Make_binable1 (S : Make_binable1_spec) = struct module B = S.Binable let bin_size_t bin_size_el t = B.bin_size_t bin_size_el (S.to_binable t) let bin_write_t bin_write_el buf ~pos t = B.bin_write_t bin_write_el buf ~pos (S.to_binable t) let bin_write_t_ bin_write_el sptr eptr t = B.bin_write_t_ bin_write_el sptr eptr (S.to_binable t) let bin_read_t bin_read_el buf ~pos_ref = S.of_binable (B.bin_read_t bin_read_el buf ~pos_ref) let bin_read_t_ bin_read_el sptr_ptr eptr = S.of_binable (B.bin_read_t_ bin_read_el sptr_ptr eptr) let bin_read_t__ bin_read_el sptr_ptr eptr n = S.of_binable (B.bin_read_t__ bin_read_el sptr_ptr eptr n) let bin_writer_t bin_writer = { size = (fun v -> bin_size_t bin_writer.size v); write = (fun buf ~pos v -> bin_write_t bin_writer.unsafe_write buf ~pos v); unsafe_write = (fun sptr eptr v -> bin_write_t_ bin_writer.unsafe_write sptr eptr v); } let bin_reader_t bin_reader = { read = (fun buf ~pos_ref -> bin_read_t bin_reader.unsafe_read buf ~pos_ref); unsafe_read = (fun sptr_ptr eptr -> bin_read_t_ bin_reader.unsafe_read sptr_ptr eptr); unsafe_vtag_read = (fun _sptr_ptr _eptr _n -> Unsafe_read_c.raise_variant_wrong_type "Bin_prot.Utils.Make_binable1.bin_reader_t") } let bin_t type_class = { writer = bin_writer_t type_class.writer; reader = bin_reader_t type_class.reader; } end module type Make_binable2_spec = sig module Binable : Binable.S2 type ('a, 'b) t val to_binable : ('a, 'b) t -> ('a, 'b) Binable.t val of_binable : ('a, 'b) Binable.t -> ('a, 'b) t end module Make_binable2 (S : Make_binable2_spec) = struct module B = S.Binable let bin_size_t bin_size_el1 bin_size_el2 t = B.bin_size_t bin_size_el1 bin_size_el2 (S.to_binable t) let bin_write_t bin_write_el1 bin_write_el2 buf ~pos t = B.bin_write_t bin_write_el1 bin_write_el2 buf ~pos (S.to_binable t) let bin_write_t_ bin_write_el1 bin_write_el2 sptr eptr t = B.bin_write_t_ bin_write_el1 bin_write_el2 sptr eptr (S.to_binable t) let bin_read_t bin_read_el1 bin_read_el2 buf ~pos_ref = S.of_binable (B.bin_read_t bin_read_el1 bin_read_el2 buf ~pos_ref) let bin_read_t_ bin_read_el1 bin_read_el2 sptr_ptr eptr = S.of_binable (B.bin_read_t_ bin_read_el1 bin_read_el2 sptr_ptr eptr) let bin_read_t__ bin_read_el1 bin_read_el2 sptr_ptr eptr n = S.of_binable (B.bin_read_t__ bin_read_el1 bin_read_el2 sptr_ptr eptr n) let bin_writer_t bin_writer1 bin_writer2 = { size = (fun v -> bin_size_t bin_writer1.size bin_writer2.size v); write = (fun buf ~pos v -> bin_write_t bin_writer1.unsafe_write bin_writer2.unsafe_write buf ~pos v); unsafe_write = (fun sptr eptr v -> bin_write_t_ bin_writer1.unsafe_write bin_writer2.unsafe_write sptr eptr v); } let bin_reader_t bin_reader1 bin_reader2 = { read = (fun buf ~pos_ref -> bin_read_t bin_reader1.unsafe_read bin_reader2.unsafe_read buf ~pos_ref); unsafe_read = (fun sptr_ptr eptr -> bin_read_t_ bin_reader1.unsafe_read bin_reader2.unsafe_read sptr_ptr eptr); unsafe_vtag_read = (fun _sptr_ptr _eptr _n -> Unsafe_read_c.raise_variant_wrong_type "Bin_prot.Utils.Make_binable2.bin_reader_t") } let bin_t type_class1 type_class2 = { writer = bin_writer_t type_class1.writer type_class2.writer; reader = bin_reader_t type_class1.reader type_class2.reader; } end module type Make_iterable_binable_spec = sig type t type el type acc val module_name : string option val length : t -> int val iter : t -> f : (el -> unit) -> unit val init : int -> acc val insert : acc -> el -> int -> acc val finish : acc -> t val bin_size_el : el Size.sizer val bin_write_el_ : el Unsafe_write_c.writer val bin_read_el_ : el Unsafe_read_c.reader end module Make_iterable_binable (S : Make_iterable_binable_spec) = struct open S let raise_concurrent_modification = match module_name with | None -> raise_concurrent_modification | Some module_name -> (fun msg -> let msg = Printf.sprintf "%s.%s" module_name msg in raise_concurrent_modification msg) let bin_size_t t = let size_ref = ref 0 in let cnt_ref = ref 0 in iter t ~f:(fun el -> size_ref := !size_ref + bin_size_el el; incr cnt_ref); let len = length t in if !cnt_ref = len then bin_size_nat0 (Nat0.unsafe_of_int len) + !size_ref else raise_concurrent_modification "bin_size_t" let bin_write_t_ sptr eptr t = let len = length t in let plen = Nat0.unsafe_of_int len in let els_sptr = Unsafe_write_c.bin_write_nat0 sptr eptr plen in let cnt_ref = ref 0 in let cur_ref = ref els_sptr in iter t ~f:(fun el -> cur_ref := bin_write_el_ !cur_ref eptr el; incr cnt_ref); if !cnt_ref = len then !cur_ref else raise_concurrent_modification "bin_write_t_" let bin_write_t buf ~pos t = let start, sptr, eptr = Write_c.unsafe_get_init buf ~pos in let cur = bin_write_t_ sptr eptr t in Unsafe_common.get_safe_buf_pos buf ~start ~cur let bin_read_t_ sptr_ptr eptr = let len = (Unsafe_read_c.bin_read_nat0 sptr_ptr eptr :> int) in let rec loop acc i = if i = len then finish acc else let new_acc = insert acc (bin_read_el_ sptr_ptr eptr) i in loop new_acc (i + 1) in loop (init len) 0 let bin_read_t buf ~pos_ref = let sptr_ptr, eptr = Unsafe_common.get_read_init buf ~pos_ref in let el = try bin_read_t_ sptr_ptr eptr with | Unsafe_read_c.Error read_err -> Read_c.handle_error buf sptr_ptr read_err | exc -> Read_c.handle_exc buf sptr_ptr exc in Read_c.at_end buf sptr_ptr pos_ref el let bin_read_t__ _sptr_ptr _eptr _n = Unsafe_read_c.raise_variant_wrong_type "t" let bin_writer_t = { size = bin_size_t; write = bin_write_t; unsafe_write = bin_write_t_; } let bin_reader_t = { read = bin_read_t; unsafe_read = bin_read_t_; unsafe_vtag_read = bin_read_t__; } let bin_t = { writer = bin_writer_t; reader = bin_reader_t; } end module type Make_iterable_binable1_spec = sig type 'a t type 'a el type 'a acc val module_name : string option val length : 'a t -> int val iter : 'a t -> f : ('a el -> unit) -> unit val init : int -> 'a acc val insert : 'a acc -> 'a el -> int -> 'a acc val finish : 'a acc -> 'a t val bin_size_el : ('a, 'a el) Size.sizer1 val bin_write_el_ : ('a, 'a el) Unsafe_write_c.writer1 val bin_read_el_ : ('a, 'a el) Unsafe_read_c.reader1 end module Make_iterable_binable1 (S : Make_iterable_binable1_spec) = struct open S let raise_concurrent_modification = match module_name with | None -> raise_concurrent_modification | Some module_name -> (fun msg -> let msg = Printf.sprintf "%s.%s" module_name msg in raise_concurrent_modification msg) let bin_size_t bin_size_a t = let size_ref = ref 0 in let cnt_ref = ref 0 in iter t ~f:(fun el -> size_ref := !size_ref + bin_size_el bin_size_a el; incr cnt_ref); let len = length t in if !cnt_ref = len then bin_size_nat0 (Nat0.unsafe_of_int len) + !size_ref else raise_concurrent_modification "bin_size_t" let bin_write_t_ bin_write_a_ sptr eptr t = let len = length t in let plen = Nat0.unsafe_of_int len in let els_sptr = Unsafe_write_c.bin_write_nat0 sptr eptr plen in let cnt_ref = ref 0 in let cur_ref = ref els_sptr in iter t ~f:(fun el -> cur_ref := bin_write_el_ bin_write_a_ !cur_ref eptr el; incr cnt_ref); if !cnt_ref = len then !cur_ref else raise_concurrent_modification "bin_write_t_" let bin_write_t bin_write_a_ buf ~pos t = let start, sptr, eptr = Write_c.unsafe_get_init buf ~pos in let cur = bin_write_t_ bin_write_a_ sptr eptr t in Unsafe_common.get_safe_buf_pos buf ~start ~cur let bin_read_t_ bin_read_a_ sptr_ptr eptr = let len = (Unsafe_read_c.bin_read_nat0 sptr_ptr eptr :> int) in let rec loop acc i = if i = len then finish acc else let new_acc = insert acc (bin_read_el_ bin_read_a_ sptr_ptr eptr) i in loop new_acc (i + 1) in loop (init len) 0 let bin_read_t bin_read_a_ buf ~pos_ref = let sptr_ptr, eptr = Unsafe_common.get_read_init buf ~pos_ref in let el = try bin_read_t_ bin_read_a_ sptr_ptr eptr with | Unsafe_read_c.Error read_err -> Read_c.handle_error buf sptr_ptr read_err | exc -> Read_c.handle_exc buf sptr_ptr exc in Read_c.at_end buf sptr_ptr pos_ref el let bin_read_t__ _sptr_ptr _eptr _n = Unsafe_read_c.raise_variant_wrong_type "t" let bin_writer_t bin_writer = { size = (fun v -> bin_size_t bin_writer.size v); write = (fun buf ~pos v -> bin_write_t bin_writer.unsafe_write buf ~pos v); unsafe_write = (fun sptr eptr v -> bin_write_t_ bin_writer.unsafe_write sptr eptr v); } let bin_reader_t bin_reader = { read = (fun buf ~pos_ref -> bin_read_t bin_reader.unsafe_read buf ~pos_ref); unsafe_read = (fun sptr_ptr eptr -> bin_read_t_ bin_reader.unsafe_read sptr_ptr eptr); unsafe_vtag_read = (fun sptr_ptr eptr n -> bin_read_t__ sptr_ptr eptr n) } let bin_t type_class = { writer = bin_writer_t type_class.writer; reader = bin_reader_t type_class.reader; } end module type Make_iterable_binable2_spec = sig type ('a, 'b) t type ('a, 'b) el type ('a, 'b) acc val module_name : string option val length : ('a, 'b) t -> int val iter : ('a, 'b) t -> f : (('a, 'b) el -> unit) -> unit val init : int -> ('a, 'b) acc val insert : ('a, 'b) acc -> ('a, 'b) el -> int -> ('a, 'b) acc val finish : ('a, 'b) acc -> ('a, 'b) t val bin_size_el : ('a, 'b, ('a, 'b) el) Size.sizer2 val bin_write_el_ : ('a, 'b, ('a, 'b) el) Unsafe_write_c.writer2 val bin_read_el_ : ('a, 'b, ('a, 'b) el) Unsafe_read_c.reader2 end module Make_iterable_binable2 (S : Make_iterable_binable2_spec) = struct open S let raise_concurrent_modification = match module_name with | None -> raise_concurrent_modification | Some module_name -> (fun msg -> let msg = Printf.sprintf "%s.%s" module_name msg in raise_concurrent_modification msg) let bin_size_t bin_size_a bin_size_b t = let size_ref = ref 0 in let cnt_ref = ref 0 in iter t ~f:(fun el -> size_ref := !size_ref + bin_size_el bin_size_a bin_size_b el; incr cnt_ref); let len = length t in if !cnt_ref = len then bin_size_nat0 (Nat0.unsafe_of_int len) + !size_ref else raise_concurrent_modification "bin_size_t" let bin_write_t_ bin_write_a_ bin_write_b_ sptr eptr t = let len = length t in let plen = Nat0.unsafe_of_int len in let els_sptr = Unsafe_write_c.bin_write_nat0 sptr eptr plen in let cnt_ref = ref 0 in let cur_ref = ref els_sptr in iter t ~f:(fun el -> cur_ref := bin_write_el_ bin_write_a_ bin_write_b_ !cur_ref eptr el; incr cnt_ref); if !cnt_ref = len then !cur_ref else raise_concurrent_modification "bin_write_t_" let bin_write_t bin_write_a_ bin_write_b_ buf ~pos t = let start, sptr, eptr = Write_c.unsafe_get_init buf ~pos in let cur = bin_write_t_ bin_write_a_ bin_write_b_ sptr eptr t in Unsafe_common.get_safe_buf_pos buf ~start ~cur let bin_read_t_ bin_read_a_ bin_read_b_ sptr_ptr eptr = let len = (Unsafe_read_c.bin_read_nat0 sptr_ptr eptr :> int) in let rec loop acc i = if i = len then finish acc else let new_acc = insert acc (bin_read_el_ bin_read_a_ bin_read_b_ sptr_ptr eptr) i in loop new_acc (i + 1) in loop (init len) 0 let bin_read_t bin_read_a_ bin_read_b_ buf ~pos_ref = let sptr_ptr, eptr = Unsafe_common.get_read_init buf ~pos_ref in let el = try bin_read_t_ bin_read_a_ bin_read_b_ sptr_ptr eptr with | Unsafe_read_c.Error read_err -> Read_c.handle_error buf sptr_ptr read_err | exc -> Read_c.handle_exc buf sptr_ptr exc in Read_c.at_end buf sptr_ptr pos_ref el let bin_read_t__ _sptr_ptr _eptr _n = Unsafe_read_c.raise_variant_wrong_type "t" let bin_writer_t bin_writer1 bin_writer2 = { size = (fun v -> bin_size_t bin_writer1.size bin_writer2.size v); write = (fun buf ~pos v -> bin_write_t bin_writer1.unsafe_write bin_writer2.unsafe_write buf ~pos v); unsafe_write = (fun sptr eptr v -> bin_write_t_ bin_writer1.unsafe_write bin_writer2.unsafe_write sptr eptr v); } let bin_reader_t bin_reader1 bin_reader2 = { read = (fun buf ~pos_ref -> bin_read_t bin_reader1.unsafe_read bin_reader2.unsafe_read buf ~pos_ref); unsafe_read = (fun sptr_ptr eptr -> bin_read_t_ bin_reader1.unsafe_read bin_reader2.unsafe_read sptr_ptr eptr); unsafe_vtag_read = (fun sptr_ptr eptr n -> bin_read_t__ sptr_ptr eptr n) } let bin_t type_class1 type_class2 = { writer = bin_writer_t type_class1.writer type_class2.writer; reader = bin_reader_t type_class1.reader type_class2.reader; } end bin_prot-109.30.00/lib/utils.mli000066400000000000000000000077661216015522300162660ustar00rootroot00000000000000(** Utility functions for user convenience *) open Common open Type_class val bin_dump : ?header : bool -> 'a writer -> 'a -> buf (** [bin_dump ?header writer v] uses [writer] to first compute the size of [v] in the binary protocol, then allocates a buffer of exactly this size, and then writes out the value. If [header] is [true], the size of the resulting binary string will be prefixed as a signed 64bit integer. @return the buffer containing the written out value. @param header default = [false] @raise Failure if the size of the value changes during writing, and any other exceptions that the binary writer in [writer] can raise. *) val bin_read_stream : ?max_size : int -> read : (buf -> pos : int -> len : int -> unit) -> 'a reader -> 'a (** [bin_read_stream ?max_size ~read reader] reads binary protocol data from a stream as generated by the [read] function, which places data of a given length into a given buffer. Requires a header. The [reader] type class will be used for conversion to OCaml-values. @param max_size = nothing @raise Failure if the size of the value disagrees with the one specified in the header, and any other exceptions that the binary reader associated with [reader] can raise. @raise Failure if the size reported in the data header is longer than [max_size]. *) (** Conversion of binable types *) module type Make_binable_spec = sig module Binable : Binable.S type t val to_binable : t -> Binable.t val of_binable : Binable.t -> t end module Make_binable (Bin_spec : Make_binable_spec) : Binable.S with type t := Bin_spec.t module type Make_binable1_spec = sig module Binable : Binable.S1 type 'a t val to_binable : 'a t -> 'a Binable.t val of_binable : 'a Binable.t -> 'a t end module Make_binable1 (Bin_spec : Make_binable1_spec) : Binable.S1 with type 'a t := 'a Bin_spec.t module type Make_binable2_spec = sig module Binable : Binable.S2 type ('a, 'b) t val to_binable : ('a, 'b) t -> ('a, 'b) Binable.t val of_binable : ('a, 'b) Binable.t -> ('a, 'b) t end module Make_binable2 (Bin_spec : Make_binable2_spec) : Binable.S2 with type ('a, 'b) t := ('a, 'b) Bin_spec.t (** Conversion of iterable types *) module type Make_iterable_binable_spec = sig type t type el type acc val module_name : string option val length : t -> int val iter : t -> f : (el -> unit) -> unit val init : int -> acc val insert : acc -> el -> int -> acc val finish : acc -> t val bin_size_el : el Size.sizer val bin_write_el_ : el Unsafe_write_c.writer val bin_read_el_ : el Unsafe_read_c.reader end module Make_iterable_binable (Iterable_spec : Make_iterable_binable_spec) : Binable.S with type t := Iterable_spec.t module type Make_iterable_binable1_spec = sig type 'a t type 'a el type 'a acc val module_name : string option val length : 'a t -> int val iter : 'a t -> f : ('a el -> unit) -> unit val init : int -> 'a acc val insert : 'a acc -> 'a el -> int -> 'a acc val finish : 'a acc -> 'a t val bin_size_el : ('a, 'a el) Size.sizer1 val bin_write_el_ : ('a, 'a el) Unsafe_write_c.writer1 val bin_read_el_ : ('a, 'a el) Unsafe_read_c.reader1 end module Make_iterable_binable1 (Iterable_spec : Make_iterable_binable1_spec) : Binable.S1 with type 'a t := 'a Iterable_spec.t module type Make_iterable_binable2_spec = sig type ('a, 'b) t type ('a, 'b) el type ('a, 'b) acc val module_name : string option val length : ('a, 'b) t -> int val iter : ('a, 'b) t -> f : (('a, 'b) el -> unit) -> unit val init : int -> ('a, 'b) acc val insert : ('a, 'b) acc -> ('a, 'b) el -> int -> ('a, 'b) acc val finish : ('a, 'b) acc -> ('a, 'b) t val bin_size_el : ('a, 'b, ('a, 'b) el) Size.sizer2 val bin_write_el_ : ('a, 'b, ('a, 'b) el) Unsafe_write_c.writer2 val bin_read_el_ : ('a, 'b, ('a, 'b) el) Unsafe_read_c.reader2 end module Make_iterable_binable2 (Iterable_spec : Make_iterable_binable2_spec) : Binable.S2 with type ('a, 'b) t := ('a, 'b) Iterable_spec.t bin_prot-109.30.00/lib/write_c.ml000066400000000000000000000076571216015522300164100ustar00rootroot00000000000000(* Write_c: wrapping unsafe C-style writers to safe ML-style ones. *) open Bigarray open Common open Unsafe_common let unsafe_get_init buf ~pos = if pos < 0 then array_bound_error () else let buf_len = Array1.dim buf in if pos > buf_len then raise Buffer_short else let start = get_sptr buf ~pos:0 in let sptr = get_sptr buf ~pos in let eptr = get_eptr buf ~pos:buf_len in start, sptr, eptr let make write_c buf ~pos el = let start, sptr, eptr = unsafe_get_init buf ~pos in let cur = write_c sptr eptr el in get_safe_buf_pos buf ~start ~cur let unmake write_ml buf ~start sptr _eptr el = let start_pos = get_buf_pos ~start ~cur:sptr in let pos = write_ml buf ~pos:start_pos el in get_sptr buf ~pos let make1 write_c write_ml_el buf ~pos el = let start, sptr, eptr = unsafe_get_init buf ~pos in let write_c_el = unmake write_ml_el buf ~start in let cur = write_c write_c_el sptr eptr el in get_safe_buf_pos buf ~start ~cur let make2 write_c write_ml_el1 write_ml_el2 buf ~pos el = let start, sptr, eptr = unsafe_get_init buf ~pos in let write_c_el1 = unmake write_ml_el1 buf ~start in let write_c_el2 = unmake write_ml_el2 buf ~start in let cur = write_c write_c_el1 write_c_el2 sptr eptr el in get_safe_buf_pos buf ~start ~cur let make3 write_c write_ml_el1 write_ml_el2 write_ml_el3 buf ~pos el = let start, sptr, eptr = unsafe_get_init buf ~pos in let write_c_el1 = unmake write_ml_el1 buf ~start in let write_c_el2 = unmake write_ml_el2 buf ~start in let write_c_el3 = unmake write_ml_el3 buf ~start in let cur = write_c write_c_el1 write_c_el2 write_c_el3 sptr eptr el in get_safe_buf_pos buf ~start ~cur let bin_write_unit = make Unsafe_write_c.bin_write_unit let bin_write_bool = make Unsafe_write_c.bin_write_bool let bin_write_string = make Unsafe_write_c.bin_write_string let bin_write_char = make Unsafe_write_c.bin_write_char let bin_write_int = make Unsafe_write_c.bin_write_int let bin_write_float = make Unsafe_write_c.bin_write_float let bin_write_int32 = make Unsafe_write_c.bin_write_int32 let bin_write_int64 = make Unsafe_write_c.bin_write_int64 let bin_write_nativeint = make Unsafe_write_c.bin_write_nativeint let bin_write_nat0 = make Unsafe_write_c.bin_write_nat0 let bin_write_ref mlw = make1 Unsafe_write_c.bin_write_ref mlw let bin_write_lazy mlw = make1 Unsafe_write_c.bin_write_lazy mlw let bin_write_option mlw = make1 Unsafe_write_c.bin_write_option mlw let bin_write_pair mlw = make2 Unsafe_write_c.bin_write_pair mlw let bin_write_triple mlw = make3 Unsafe_write_c.bin_write_triple mlw let bin_write_list mlw = make1 Unsafe_write_c.bin_write_list mlw let bin_write_array mlw = make1 Unsafe_write_c.bin_write_array mlw let bin_write_hashtbl mlw = make2 Unsafe_write_c.bin_write_hashtbl mlw let bin_write_float32_vec = make Unsafe_write_c.bin_write_float32_vec let bin_write_float64_vec = make Unsafe_write_c.bin_write_float64_vec let bin_write_vec = make Unsafe_write_c.bin_write_vec let bin_write_float32_mat = make Unsafe_write_c.bin_write_float32_mat let bin_write_float64_mat = make Unsafe_write_c.bin_write_float64_mat let bin_write_mat = make Unsafe_write_c.bin_write_mat let bin_write_bigstring = make Unsafe_write_c.bin_write_bigstring let bin_write_float_array = make Unsafe_write_c.bin_write_float_array let bin_write_variant_tag el = make Unsafe_write_c.bin_write_variant_tag el let bin_write_array_no_length mlw = make1 Unsafe_write_c.bin_write_array_no_length mlw let bin_write_int_64bit = make Unsafe_write_c.bin_write_int_64bit let bin_write_int64_bits = make Unsafe_write_c.bin_write_int64_bits let bin_write_network16_int = make Unsafe_write_c.bin_write_network16_int let bin_write_network32_int = make Unsafe_write_c.bin_write_network32_int let bin_write_network32_int32 = make Unsafe_write_c.bin_write_network32_int32 let bin_write_network64_int = make Unsafe_write_c.bin_write_network64_int let bin_write_network64_int64 = make Unsafe_write_c.bin_write_network64_int64 bin_prot-109.30.00/lib/write_c.mli000066400000000000000000000067501216015522300165520ustar00rootroot00000000000000(** Wrapping unsafe C-style writers to safe ML-style ones. *) open Common open Unsafe_common open Write_ml (** {2 Generic functions for easy creation of wrappers} *) val unsafe_get_init : buf -> pos : pos -> sptr * sptr * eptr (** [unsafe_get_init buf ~pos] @return the triple [(start, sptr, eptr)] where [start] is the pointer to the start of buffer [buf], [sptr] the pointer to the position [pos] in [buf], and [eptr] the pointer to the end of the buffer. NOTE: you must make sure that [buf] remains unreclaimed as long as any of the three pointers is accessible! *) val make : 'a Unsafe_write_c.writer -> 'a Write_ml.writer (** [make c_writer] takes an unsafe C-style writer [c_writer]. @return a safe ML-style writer. *) val make1 : ('a, 'b) Unsafe_write_c.writer1 -> ('a, 'b) Write_ml.writer1 (** [make1 mk_c_writer ml_el_writer] takes a higher-order C-style writer [mk_c_writer] and an ML-writer [ml_el_writer] that operates on the same type as the argument of the C-style writer. @return ML-style writer for the higher-order type. *) val make2 : ('a, 'b, 'c) Unsafe_write_c.writer2 -> ('a, 'b, 'c) Write_ml.writer2 (** [make2 mk_c_writer ml_el1_writer ml_el2_writer] like {!make1} but operates on unsafe C-style write functions for types with two type parameters. *) val make3 : ('a, 'b, 'c, 'd) Unsafe_write_c.writer3 -> ('a, 'b, 'c, 'd) Write_ml.writer3 (** [make3 mk_c_writer ml_el1_writer ml_el2_writer ml_el3_writer] like {!make1} but operates on unsafe C-style write functions for types with three type parameters. *) val unmake : 'a Write_ml.writer -> buf -> start : sptr -> 'a Unsafe_write_c.writer (** [unmake ml_writer buf ~start] takes an ML-style writer [ml_writer], a buffer, and the pointer [start] to the start of the buffer. This function can be used to wrap higher-order type conversion functions and, together with {!unsafe_get_init}, is used in e.g. {!make1}, {!make2} and {!make3} for that purpose. @return an unsafe C-style writer. *) (** {2 Unsafe C-style writers for basic types wrapped as ML-style writers} *) val bin_write_unit : unit writer val bin_write_bool : bool writer val bin_write_string : string writer val bin_write_char : char writer val bin_write_int : int writer val bin_write_nat0 : Nat0.t writer val bin_write_float : float writer val bin_write_int32 : int32 writer val bin_write_int64 : int64 writer val bin_write_nativeint : nativeint writer val bin_write_ref : ('a, 'a ref) writer1 val bin_write_lazy : ('a, 'a lazy_t) writer1 val bin_write_option : ('a, 'a option) writer1 val bin_write_pair : ('a, 'b, 'a * 'b) writer2 val bin_write_triple : ('a, 'b, 'c, 'a * 'b * 'c) writer3 val bin_write_list : ('a, 'a list) writer1 val bin_write_array : ('a, 'a array) writer1 val bin_write_hashtbl : ('a, 'b, ('a, 'b) Hashtbl.t) writer2 val bin_write_float32_vec : vec32 writer val bin_write_float64_vec : vec64 writer val bin_write_vec : vec writer val bin_write_float32_mat : mat32 writer val bin_write_float64_mat : mat64 writer val bin_write_mat : mat writer val bin_write_bigstring : buf writer val bin_write_float_array : float array writer val bin_write_variant_tag : [> ] writer val bin_write_array_no_length : ('a, 'a array) writer1 val bin_write_int_64bit : int writer val bin_write_int64_bits : int64 writer val bin_write_network16_int : int writer val bin_write_network32_int : int writer val bin_write_network32_int32 : int32 writer val bin_write_network64_int : int writer val bin_write_network64_int64 : int64 writer bin_prot-109.30.00/lib/write_ml.ml000066400000000000000000000230031216015522300165550ustar00rootroot00000000000000(* Write_ml: writing values to the binary protocol using (mostly) OCaml. *) #include "int_codes.mlh" open Common type 'a writer = buf -> pos : pos -> 'a -> pos type ('a, 'b) writer1 = 'a writer -> 'b writer type ('a, 'b, 'c) writer2 = 'a writer -> ('b, 'c) writer1 type ('a, 'b, 'c, 'd) writer3 = 'a writer -> ('b, 'c, 'd) writer2 let bin_write_unit buf ~pos () = check_pos buf pos; buf.{pos} <- '\000'; pos + 1 let bin_write_bool (buf : buf) ~pos b = check_pos buf pos; buf.{pos} <- if b then '\001' else '\000'; pos + 1 let all_bin_write_small_int (buf : buf) ~pos n = check_pos buf pos; buf.{pos} <- Char.unsafe_chr n; pos + 1 let all_bin_write_neg_int8 (buf : buf) ~pos n = let next = pos + 2 in check_next buf next; buf.{pos} <- Char.unsafe_chr code_neg_int8; buf.{pos + 1} <- Char.unsafe_chr n; next let all_bin_write_int16 (buf : buf) ~pos n = let next = pos + 3 in check_next buf next; buf.{pos} <- Char.unsafe_chr code_int16; buf.{pos + 1} <- Char.unsafe_chr n; buf.{pos + 2} <- Char.unsafe_chr (n asr 8); next let all_bin_write_int32 (buf : buf) ~pos n = let next = pos + 5 in check_next buf next; buf.{pos} <- Char.unsafe_chr code_int32; buf.{pos + 1} <- Char.unsafe_chr n; buf.{pos + 2} <- Char.unsafe_chr (n asr 8); buf.{pos + 3} <- Char.unsafe_chr (n asr 16); buf.{pos + 4} <- Char.unsafe_chr (n asr 24); next #ifdef ARCH_SIXTYFOUR let all_bin_write_int64 (buf : buf) ~pos n = let next = pos + 9 in check_next buf next; buf.{pos} <- Char.unsafe_chr code_int64; buf.{pos + 1} <- Char.unsafe_chr n; buf.{pos + 2} <- Char.unsafe_chr (n asr 8); buf.{pos + 3} <- Char.unsafe_chr (n asr 16); buf.{pos + 4} <- Char.unsafe_chr (n asr 24); buf.{pos + 5} <- Char.unsafe_chr (n asr 32); buf.{pos + 6} <- Char.unsafe_chr (n asr 40); buf.{pos + 7} <- Char.unsafe_chr (n asr 48); buf.{pos + 8} <- Char.unsafe_chr (n asr 56); next #endif let bin_write_int_nat0 buf ~pos n = if n < 0x00000080 then all_bin_write_small_int buf ~pos n else if n < 0x00008000 then all_bin_write_int16 buf ~pos n #ifdef ARCH_SIXTYFOUR else if n >= 0x80000000 then all_bin_write_int64 buf ~pos n #endif else all_bin_write_int32 buf ~pos n let bin_write_int_negative buf ~pos n = if n >= -0x00000080 then all_bin_write_neg_int8 buf ~pos n else if n >= -0x00008000 then all_bin_write_int16 buf ~pos n #ifdef ARCH_SIXTYFOUR else if n < -0x80000000 then all_bin_write_int64 buf ~pos n #endif else all_bin_write_int32 buf ~pos n let bin_write_char (buf : buf) ~pos c = check_pos buf pos; buf.{pos} <- c; pos + 1 let bin_write_int buf ~pos n = if n >= 0 then bin_write_int_nat0 buf ~pos n else bin_write_int_negative buf ~pos n let bin_write_nat0 buf ~pos nat0 = let n = (nat0 : Nat0.t :> int) in if n < 0x00000080 then all_bin_write_small_int buf ~pos n else if n < 0x00010000 then all_bin_write_int16 buf ~pos n #ifdef ARCH_SIXTYFOUR else if n >= 0x100000000 then all_bin_write_int64 buf ~pos n #endif else all_bin_write_int32 buf ~pos n let bin_write_string buf ~pos str = let len = String.length str in let plen = Nat0.unsafe_of_int len in let new_pos = bin_write_nat0 buf ~pos plen in let next = new_pos + len in check_next buf next; (* TODO: optimize for small strings *) unsafe_blit_string_buf ~src_pos:0 str ~dst_pos:new_pos buf ~len; next external bin_write_float : buf -> pos : int -> float -> int = "ml_write_float_stub" #ifdef ARCH_SIXTYFOUR let bin_write_int32 buf ~pos n = bin_write_int buf ~pos (Int32.to_int n) #else let bin_write_int32 buf ~pos n = if n >= 0x00008000l || n < -0x00008000l then let next = pos + 5 in check_next buf next; buf.{pos} <- Char.unsafe_chr code_int32; let n_int = Int32.to_int n in buf.{pos + 1} <- Char.unsafe_chr n_int; buf.{pos + 2} <- Char.unsafe_chr (n_int asr 8); buf.{pos + 3} <- Char.unsafe_chr (n_int asr 16); buf.{pos + 4} <- Char.unsafe_chr (Int32.to_int (Int32.shift_right n 24)); next else bin_write_int buf ~pos (Int32.to_int n) #endif #ifdef ARCH_SIXTYFOUR let bin_write_int64 buf ~pos n = if n >= 0x80000000L || n < -0x80000000L then let next = pos + 9 in check_next buf next; buf.{pos} <- Char.unsafe_chr code_int64; let n_int = Int64.to_int n in buf.{pos + 1} <- Char.unsafe_chr n_int; buf.{pos + 2} <- Char.unsafe_chr (n_int asr 8); buf.{pos + 3} <- Char.unsafe_chr (n_int asr 16); buf.{pos + 4} <- Char.unsafe_chr (n_int asr 24); buf.{pos + 5} <- Char.unsafe_chr (n_int asr 32); buf.{pos + 6} <- Char.unsafe_chr (n_int asr 40); buf.{pos + 7} <- Char.unsafe_chr (n_int asr 48); buf.{pos + 8} <- Char.unsafe_chr (Int64.to_int (Int64.shift_right n 56)); next else bin_write_int buf ~pos (Int64.to_int n) #else let bin_write_int64 buf ~pos n = if n >= 0x80000000L || n < -0x80000000L then let next = pos + 9 in check_next buf next; buf.{pos} <- Char.unsafe_chr code_int64; let n1_int = Int64.to_int n in buf.{pos + 1} <- Char.unsafe_chr n1_int; buf.{pos + 2} <- Char.unsafe_chr (n1_int asr 8); buf.{pos + 3} <- Char.unsafe_chr (n1_int asr 16); let n2_int = Int64.to_int (Int64.shift_right n 24) in buf.{pos + 4} <- Char.unsafe_chr n2_int; buf.{pos + 5} <- Char.unsafe_chr (n2_int asr 8); buf.{pos + 6} <- Char.unsafe_chr (n2_int asr 16); let n3_int = Int64.to_int (Int64.shift_right n 48) in buf.{pos + 7} <- Char.unsafe_chr n3_int; buf.{pos + 8} <- Char.unsafe_chr (n3_int asr 8); next else bin_write_int32 buf ~pos (Int64.to_int32 n) #endif let bin_write_nativeint buf ~pos n = #ifdef ARCH_SIXTYFOUR bin_write_int64 buf ~pos (Int64.of_nativeint n) #else bin_write_int32 buf ~pos (Nativeint.to_int32 n) #endif let bin_write_ref bin_write_el buf ~pos r = bin_write_el buf ~pos !r let bin_write_lazy bin_write_el buf ~pos lv = let v = Lazy.force lv in bin_write_el buf ~pos v let bin_write_option bin_write_el buf ~pos = function | None -> bin_write_bool buf ~pos false | Some v -> let next = bin_write_bool buf ~pos true in bin_write_el buf ~pos:next v let bin_write_pair bin_write_a bin_write_b buf ~pos (a, b) = let next = bin_write_a buf ~pos a in bin_write_b buf ~pos:next b let bin_write_triple bin_write_a bin_write_b bin_write_c buf ~pos (a, b, c) = let next1 = bin_write_a buf ~pos a in let next2 = bin_write_b buf ~pos:next1 b in bin_write_c buf ~pos:next2 c let bin_write_list bin_write_el buf ~pos lst = let rec loop els_pos = function | [] -> els_pos | h :: t -> let new_els_pos = bin_write_el buf ~pos:els_pos h in loop new_els_pos t in let len = Nat0.unsafe_of_int (List.length lst) in let els_pos = bin_write_nat0 buf ~pos len in loop els_pos lst let bin_write_array_loop bin_write_el buf ~els_pos ~n ar = let els_pos_ref = ref els_pos in for i = 0 to n - 1 do els_pos_ref := bin_write_el buf ~pos:!els_pos_ref (Array.unsafe_get ar i) done; !els_pos_ref let bin_write_array bin_write_el buf ~pos ar = let n = Array.length ar in let pn = Nat0.unsafe_of_int n in let els_pos = bin_write_nat0 buf ~pos pn in bin_write_array_loop bin_write_el buf ~els_pos ~n ar let bin_write_hashtbl bin_write_key bin_write_val buf ~pos htbl = let len = Hashtbl.length htbl in let plen = Nat0.unsafe_of_int len in let els_pos = bin_write_nat0 buf ~pos plen in let cnt_ref = ref 0 in let coll_htbl k v els_pos = incr cnt_ref; let new_els_pos = bin_write_key buf ~pos:els_pos k in bin_write_val buf ~pos:new_els_pos v in let res_pos = Hashtbl.fold coll_htbl htbl els_pos in if !cnt_ref <> len then raise_concurrent_modification "bin_write_hashtbl"; res_pos external bin_write_float32_vec : buf -> pos : int -> vec32 -> int = "ml_write_float32_vec_stub" external bin_write_float64_vec : buf -> pos : int -> vec64 -> int = "ml_write_float64_vec_stub" external bin_write_vec : buf -> pos : int -> vec -> int = "ml_write_float64_vec_stub" external bin_write_float32_mat : buf -> pos : int -> mat32 -> int = "ml_write_float32_mat_stub" external bin_write_float64_mat : buf -> pos : int -> mat64 -> int = "ml_write_float64_mat_stub" external bin_write_mat : buf -> pos : int -> mat -> int = "ml_write_float64_mat_stub" external bin_write_bigstring : buf -> pos : int -> buf -> int = "ml_write_bigstring_stub" external bin_write_float_array : buf -> pos : int -> float array -> int = "ml_write_float_array_stub" external bin_write_variant_tag : buf -> pos : int -> [> ] -> int = "ml_write_variant_tag_stub" external bin_write_int_8bit : buf -> pos : int -> int -> int = "ml_write_int_8bit_stub" external bin_write_int_16bit : buf -> pos : int -> int -> int = "ml_write_int_16bit_stub" external bin_write_int_32bit : buf -> pos : int -> int -> int = "ml_write_int_32bit_stub" external bin_write_int_64bit : buf -> pos : int -> int -> int = "ml_write_int_64bit_stub" external bin_write_int64_bits : buf -> pos : int -> int64 -> int = "ml_write_int64_bits_stub" external bin_write_network16_int : buf -> pos : int -> int -> int = "ml_write_network16_int_stub" external bin_write_network32_int : buf -> pos : int -> int -> int = "ml_write_network32_int_stub" external bin_write_network32_int32 : buf -> pos : int -> int32 -> int = "ml_write_network32_int32_stub" external bin_write_network64_int : buf -> pos : int -> int -> int = "ml_write_network64_int_stub" external bin_write_network64_int64 : buf -> pos : int -> int64 -> int = "ml_write_network64_int64_stub" let bin_write_array_no_length bin_write_el buf ~pos ar = bin_write_array_loop bin_write_el buf ~els_pos:pos ~n:(Array.length ar) ar bin_prot-109.30.00/lib/write_ml.mli000066400000000000000000000067451216015522300167440ustar00rootroot00000000000000(** Writing values to the binary protocol using (mostly) OCaml. *) open Common type 'a writer = buf -> pos : pos -> 'a -> pos (** Type of writer functions for the binary protocol. They take a buffer, a write position and a value, and return the next position after writing out the value. *) type ('a, 'b) writer1 = 'a writer -> 'b writer type ('a, 'b, 'c) writer2 = 'a writer -> ('b, 'c) writer1 type ('a, 'b, 'c, 'd) writer3 = 'a writer -> ('b, 'c, 'd) writer2 val bin_write_unit : unit writer val bin_write_bool : bool writer val bin_write_string : string writer val bin_write_char : char writer val bin_write_int : int writer val bin_write_nat0 : Nat0.t writer val bin_write_float : float writer val bin_write_int32 : int32 writer val bin_write_int64 : int64 writer val bin_write_nativeint : nativeint writer val bin_write_ref : ('a, 'a ref) writer1 val bin_write_lazy : ('a, 'a lazy_t) writer1 val bin_write_option : ('a, 'a option) writer1 val bin_write_pair : ('a, 'b, 'a * 'b) writer2 val bin_write_triple : ('a, 'b, 'c, 'a * 'b * 'c) writer3 val bin_write_list : ('a, 'a list) writer1 val bin_write_array : ('a, 'a array) writer1 val bin_write_hashtbl : ('a, 'b, ('a, 'b) Hashtbl.t) writer2 val bin_write_float32_vec : vec32 writer val bin_write_float64_vec : vec64 writer val bin_write_vec : vec writer val bin_write_float32_mat : mat32 writer val bin_write_float64_mat : mat64 writer val bin_write_mat : mat writer val bin_write_bigstring : buf writer val bin_write_float_array : float array writer val bin_write_variant_tag : [> ] writer (** [bin_write_variant_tag] writes out the exact little-endian bit representation of the variant tag of the given value (= 32 bits). *) val bin_write_int_8bit : int writer (** [bin_write_int_8bit] writes out the exact little-endian bit representation of the given [int] value using the lower 8 bits. *) val bin_write_int_16bit : int writer (** [bin_write_int_16bit] writes out the exact little-endian bit representation of the given [int] value using the lower 16 bits. *) val bin_write_int_32bit : int writer (** [bin_write_int_32bit] writes out the exact little-endian bit representation of the given [int] value using the lower 32 bits. *) val bin_write_int_64bit : int writer (** [bin_write_int_64bit] writes out the exact little-endian bit representation of the given [int] value using all 64 bits. On 32bit platforms negative numbers will be sign-extended in the 64bit representation. *) val bin_write_int64_bits : int64 writer (** [bin_write_int64_bits] writes out the exact little-endian bit representation of the given [int64] value. *) val bin_write_network16_int : int writer (** [bin_write_network16_int] writes out an integer in 16bit network byte order (= big-endian). *) val bin_write_network32_int : int writer (** [bin_write_network32_int] writes out an integer in 32bit network byte order (= big-endian). *) val bin_write_network32_int32 : int32 writer (** [bin_write_network32_int32] writes out a 32bit integer in 32bit network byte order (= big-endian). *) val bin_write_network64_int : int writer (** [bin_write_network64_int] writes out an integer in 64bit network byte order (= big-endian). *) val bin_write_network64_int64 : int64 writer (** [bin_write_network64_int64] writes out a 64bit integer in 64bit network byte order (= big-endian). *) val bin_write_array_no_length : ('a, 'a array) writer1 (** [bin_write_array_no_length] writes out all values in the given array without writing out its length. *) bin_prot-109.30.00/lib/write_stubs.c000066400000000000000000000377321216015522300171350ustar00rootroot00000000000000/* Stubs for writing basic values in the binary protocol */ #include "common_stubs.h" /* Utility macros */ #define MK_ML_WRITER(NAME) \ CAMLprim value ml_write_##NAME##_stub(value v_buf, value v_pos, value v_v) \ { \ struct caml_ba_array *buf = Caml_ba_array_val(v_buf); \ char *start = buf->data; \ long pos = Long_val(v_pos); \ char *sptr = start + pos; \ char *eptr = start + *buf->dim; \ if (unlikely(pos < 0)) caml_array_bound_error(); \ sptr = (char *) write_##NAME##_stub(sptr, eptr, v_v); \ return Val_long(sptr - start); \ } /* Writing OCaml integers */ static inline void do_write_small_int(char *sptr, char n) { *sptr = n; } static inline value write_small_int(char *sptr, char *eptr, char n) { if (unlikely(sptr >= eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); do_write_small_int(sptr, n); return (value) (sptr + 1); } static inline void do_write_neg_int8(char *sptr, char n) { *sptr++ = CODE_NEG_INT8; *(char *) sptr = n; } static inline value write_neg_int8(char *sptr, char *eptr, char n) { char *next = sptr + 2; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); do_write_neg_int8(sptr, n); return (value) next; } static inline void do_write_int16(char *sptr, short n) { *sptr++ = CODE_INT16; le16enc(sptr, n); } static inline value write_int16(char *sptr, char *eptr, short n) { char *next = sptr + 3; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); do_write_int16(sptr, n); return (value) next; } static inline void do_write_int32(char *sptr, int n) { *sptr++ = CODE_INT32; le32enc(sptr, n); } static inline value write_int32(char *sptr, char *eptr, int n) { char *next = sptr + 5; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); do_write_int32(sptr, n); return (value) next; } #ifdef ARCH_SIXTYFOUR static inline void do_write_int64(char *sptr, long n) { *sptr++ = CODE_INT64; le64enc(sptr, n); } static inline value write_int64(char *sptr, char *eptr, long n) { char *next = sptr + 9; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); do_write_int64(sptr, n); return (value) next; } #endif static inline value write_int_nat0(char *sptr, char *eptr, unsigned long n) { if (likely(n < 0x00000080ul)) return write_small_int(sptr, eptr, (char) n); if (likely(n < 0x00008000ul)) return write_int16(sptr, eptr, (short) n); #ifdef ARCH_SIXTYFOUR if (unlikely(n >= 0x80000000ul)) return write_int64(sptr, eptr, (long) n); #endif return write_int32(sptr, eptr, (int) n); } static inline value write_int_negative(char *sptr, char *eptr, long n) { if (likely(n >= -0x00000080l)) return write_neg_int8(sptr, eptr, (char) n); if (likely(n >= -0x00008000l)) return write_int16(sptr, eptr, (short) n); #ifdef ARCH_SIXTYFOUR if (unlikely(n < -0x80000000l)) return write_int64(sptr, eptr, (long) n); #endif return write_int32(sptr, eptr, (int) n); } static inline value write_int(char *sptr, char *eptr, long n) { /* Positive numbers (including zero) */ if (likely(n >= 0)) return write_int_nat0(sptr, eptr, (unsigned long) n); /* Negative numbers */ return write_int_negative(sptr, eptr, n); } CAMLprim value write_int_stub(char *sptr, char *eptr, value v_n) { return write_int(sptr, eptr, Long_val(v_n)); } /* Writing natural numbers (including zero) */ static inline value write_nat0(char *sptr, char *eptr, unsigned long n) { if (likely(n < 0x00000080ul)) return write_small_int(sptr, eptr, (char) n); if (likely(n < 0x00010000ul)) return write_int16(sptr, eptr, (short) n); #ifdef ARCH_SIXTYFOUR if (unlikely(n >= 0x100000000UL)) return write_int64(sptr, eptr, (long) n); #endif return write_int32(sptr, eptr, (int) n); } CAMLprim value write_nat0_stub(char *sptr, char *eptr, value v_n) { return write_nat0(sptr, eptr, (unsigned long) Long_val(v_n)); } /* Writing 32bit integers */ CAMLprim value write_int32_stub(char *sptr, char *eptr, value v_n) { return write_int(sptr, eptr, Int32_val(v_n)); } /* Writing 64bit integers */ #ifndef ARCH_SIXTYFOUR static inline value write_int64_type(char *sptr, char *eptr, int64 n) { char *next = sptr + 9; int32 lower, upper; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *sptr++ = CODE_INT64; I64_split(n, upper, lower); le32enc(sptr, lower); le32enc(sptr + 4, upper); return (value) next; } static inline value write_int64_type_nat0(char *sptr, char *eptr, int64 n) { if (likely((I64_compare(n, I64_literal(0, 0x00000080l)) < 0))) return write_small_int(sptr, eptr, (char) I64_to_int32(n)); if (likely(I64_compare(n, I64_literal(0, 0x00008000l)) < 0)) return write_int16(sptr, eptr, (short) I64_to_int32(n)); if (unlikely(I64_compare(n, I64_literal(0, 0x80000000l)) >= 0)) return write_int64_type(sptr, eptr, n); return write_int32(sptr, eptr, (int) I64_to_int32(n)); } static inline value write_int64_type_negative(char *sptr, char *eptr, int64 n) { if (likely(I64_compare(n, I64_literal(0xFFFFFFFF, -0x00000080l)) >= 0)) return write_neg_int8(sptr, eptr, (char) I64_to_int32(n)); if (likely(I64_compare(n, I64_literal(0xFFFFFFFF, -0x00008000l)) >= 0)) return write_int16(sptr, eptr, (short) I64_to_int32(n)); if (unlikely(I64_compare(n, I64_literal(0xFFFFFFFF, -0x80000000l)) < 0)) return write_int64_type(sptr, eptr, n); return write_int32(sptr, eptr, I64_to_int32(n)); } #endif CAMLprim value write_int64_stub(char *sptr, char *eptr, value v_n) { int64 n = Int64_val(v_n); #ifdef ARCH_SIXTYFOUR return write_int(sptr, eptr, n); #else if (likely(! I64_is_negative(n))) return write_int64_type_nat0(sptr, eptr, n); return write_int64_type_negative(sptr, eptr, n); #endif } /* Writing nativeints */ CAMLprim value write_nativeint_stub(char *sptr, char *eptr, value v_n) { long n = Nativeint_val(v_n); return write_int(sptr, eptr, n); } /* Writing booleans and characters */ CAMLprim value write_small_int_stub(char *sptr, char *eptr, value v_n) { return write_small_int(sptr, eptr, (char) Int_val(v_n)); } /* Writing strings */ CAMLprim value write_string_stub(char *sptr, char *eptr, value v_str) { char *str = String_val(v_str); unsigned long len = caml_string_length(v_str); char *next, *dst; if (likely(len < 0x00000014ul)) { /* Speedup for copying small strings */ dst = sptr + 1; next = dst + len; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *sptr = (char) len; if (likely(len-- > 0)) do dst[len] = str[len]; while (likely(len-- != 0)); return (value) next; } if (likely(len < 0x00000080ul)) { dst = sptr + 1; next = dst + len; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *sptr = (char) len; memcpy(dst, str, (size_t) len); return (value) next; } if (likely(len < 0x00010000ul)) { dst = sptr + 3; next = dst + len; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); do_write_int16(sptr, (short) len); memcpy(dst, str, (size_t) len); return (value) next; } #ifdef ARCH_SIXTYFOUR if (unlikely(len >= 0x100000000UL)) { dst = sptr + 9; next = dst + len; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); do_write_int64(sptr, len); memcpy(dst, str, (size_t) len); return (value) next; } #endif else { dst = sptr + 5; next = dst + len; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); do_write_int32(sptr, (unsigned int) len); memcpy(dst, str, (size_t) len); return (value) next; } } /* Writing floats and float arrays */ CAMLprim inline value write_float_stub(char *sptr, char *eptr, value v_n) { char *next = sptr + sizeof(double); double n = Double_val(v_n); if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); memcpy(sptr, &n, sizeof(double)); return (value) next; } MK_ML_WRITER(float) CAMLprim inline value write_float_array_stub(char *sptr, char *eptr, value v_ar) { unsigned long wlen = Wosize_val(v_ar); double *src = (double *) v_ar; unsigned long len = wlen / Double_wosize; unsigned long tot_size = len * sizeof(double); char *next, *dst; if (likely(len < 0x00000080ul)) { dst = (char *) sptr + 1; next = dst + tot_size; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *(char *) sptr = (char) len; memcpy(dst, src, (size_t) tot_size); return (value) next; } if (likely(len < 0x00010000ul)) { dst = (char *) sptr + 3; next = dst + tot_size; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); do_write_int16(sptr, (short) len); memcpy(dst, src, (size_t) tot_size); return (value) next; } #ifdef ARCH_SIXTYFOUR if (likely(len >= 0x100000000UL)) { dst = (char *) sptr + 9; next = dst + tot_size; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); do_write_int64(sptr, len); memcpy(dst, src, (size_t) tot_size); return (value) next; } #endif else { dst = (char *) sptr + 5; next = dst + tot_size; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); do_write_int32(sptr, (int) len); memcpy(dst, src, (size_t) tot_size); return (value) next; } } MK_ML_WRITER(float_array) /* Writing polymorphic variants */ CAMLprim inline value write_variant_tag_stub( char *sptr, char *eptr, value v_tag) { char *next = sptr + 4; int tag; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); tag = (int) (Is_block(v_tag) ? Field(v_tag, 0) : v_tag); le32enc(sptr, tag); return (value) next; } MK_ML_WRITER(variant_tag) /* Writing raw strings */ CAMLprim inline value write_raw_string_stub( char *sptr, char *eptr, value v_str, value v_pos, value v_len) { size_t pos = (size_t) Long_val(v_pos), len = (size_t) Long_val(v_len); char *next = sptr + len; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); memcpy(sptr, String_val(v_str) + pos, len); return (value) next; } /* Writing bigarrays */ static inline value write_area( value v, void *sptr, char *eptr, void *src, unsigned long len, size_t tot_size) { char *next, *dst; if (likely(len < 0x00000080ul)) { dst = ((char *) sptr) + 1; next = dst + tot_size; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *(char *) sptr = (char) len; memcpy(dst, src, tot_size); return (value) next; } if (likely(len < 0x00010000ul)) { dst = (char *) sptr + 3; next = dst + tot_size; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); do_write_int16(sptr, (short) len); memcpy(dst, src, tot_size); return (value) next; } #ifdef ARCH_SIXTYFOUR if (unlikely(len >= 0x100000000UL)) { dst = (char *) sptr + 9; next = dst + tot_size; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); Begin_roots1(v); caml_enter_blocking_section(); do_write_int64(sptr, len); memcpy(dst, src, tot_size); caml_leave_blocking_section(); End_roots(); return (value) next; } #endif else { dst = (char *) sptr + 5; next = dst + tot_size; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); Begin_roots1(v); caml_enter_blocking_section(); do_write_int32(sptr, (int) len); memcpy(dst, src, tot_size); caml_leave_blocking_section(); End_roots(); return (value) next; } } #define MK_BA1_WRITER(NAME, TYPE) \ CAMLprim inline value \ write_##NAME##_stub(char *sptr, char *eptr, value v_v) \ { \ struct caml_ba_array *vec = Caml_ba_array_val(v_v); \ unsigned long len = (unsigned long) *vec->dim; \ return \ write_area( \ v_v, sptr, eptr, vec->data, len, (size_t) len * sizeof(TYPE)); \ } \ \ MK_ML_WRITER(NAME) MK_BA1_WRITER(bigstring, char) #define MK_VEC_MAT_WRITERS(NAME, TYPE) \ MK_BA1_WRITER(NAME##_vec, TYPE) \ \ CAMLprim inline value \ write_##NAME##_mat_stub(char *sptr, char *eptr, value v_m) \ { \ struct caml_ba_array *mat = Caml_ba_array_val(v_m); \ unsigned long dim1 = (unsigned long) mat->dim[0]; \ unsigned long dim2 = (unsigned long) mat->dim[1]; \ unsigned long size = dim1 * dim2; \ sptr = (char *) write_nat0(sptr, eptr, dim1); \ return \ write_area( \ v_m, sptr, eptr, mat->data, dim2, (size_t) size * sizeof(TYPE)); \ } \ MK_ML_WRITER(NAME##_mat) MK_VEC_MAT_WRITERS(float32, float) MK_VEC_MAT_WRITERS(float64, double) /* Writing bits */ CAMLprim value write_int_8bit_stub(char *sptr, char *eptr, value v_n) { char *next = sptr + 1; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); *(char *) sptr = (char) Int_val(v_n); return (value) next; } MK_ML_WRITER(int_8bit) CAMLprim value write_int_16bit_stub(char *sptr, char *eptr, value v_n) { char *next = sptr + 2; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); le16enc(sptr, Int_val(v_n)); return (value) next; } MK_ML_WRITER(int_16bit) CAMLprim value write_int_32bit_stub(char *sptr, char *eptr, value v_n) { char *next = sptr + 4; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); le32enc(sptr, Int_val(v_n)); return (value) next; } MK_ML_WRITER(int_32bit) CAMLprim value write_int_64bit_stub(char *sptr, char *eptr, value v_n) { char *next = sptr + 8; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); #ifdef ARCH_SIXTYFOUR le64enc(sptr, Long_val(v_n)); #else { long n = Long_val(v_n); long tmp = (n < 0) ? 0xFFFFFFFFl : 0l; le32enc(sptr, n); memcpy(sptr + 4, &tmp, sizeof(long)); } #endif return (value) next; } MK_ML_WRITER(int_64bit) CAMLprim inline value write_int64_bits_stub(char *sptr, char *eptr, value v_n) { char *next = sptr + 8; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); #ifdef ARCH_SIXTYFOUR le64enc(sptr, Int64_val(v_n)); #else { int64 n = Int64_val(v_n); unsigned int lower, upper; I64_split(n, upper, lower); le32enc(sptr, lower); le32enc(sptr + 4, upper); } #endif return (value) next; } MK_ML_WRITER(int64_bits) CAMLprim inline value write_network16_int_stub( char *sptr, char *eptr, value v_n) { char *next = sptr + 2; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); be16enc(sptr, Int_val(v_n)); return (value) next; } MK_ML_WRITER(network16_int) CAMLprim inline value write_network32_int_stub( char *sptr, char *eptr, value v_n) { char *next = sptr + 4; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); be32enc(sptr, Int_val(v_n)); return (value) next; } MK_ML_WRITER(network32_int) CAMLprim inline value write_network32_int32_stub( char *sptr, char *eptr, value v_n) { char *next = sptr + 4; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); be32enc(sptr, Int32_val(v_n)); return (value) next; } MK_ML_WRITER(network32_int32) CAMLprim inline value write_network64_int_stub( char *sptr, char *eptr, value v_n) { char *next = sptr + 8; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); #ifdef ARCH_SIXTYFOUR be64enc(sptr, Long_val(v_n)); #else /* 32bit */ { unsigned int tmp = 0; memcpy(sptr, &tmp, 4); be32enc(sptr + 4, Long_val(v_n)); } #endif return (value) next; } MK_ML_WRITER(network64_int) CAMLprim inline value write_network64_int64_stub( char *sptr, char *eptr, value v_n) { char *next = sptr + 8; if (unlikely(next > eptr)) caml_raise_constant(*v_bin_prot_exc_Buffer_short); #ifdef ARCH_SIXTYFOUR be64enc(sptr, Int64_val(v_n)); #else /* 32bit */ { int64 n = Int64_val(v_n); uint32_t lower, upper; I64_split(n, upper, lower); be32enc(sptr, upper); be32enc(sptr + 4, lower); } #endif return (value) next; } MK_ML_WRITER(network64_int64) bin_prot-109.30.00/lib_test/000077500000000000000000000000001216015522300154425ustar00rootroot00000000000000bin_prot-109.30.00/lib_test/bin_prot_test.ml000066400000000000000000001066571216015522300206660ustar00rootroot00000000000000open Bigarray open Printf open OUnit open Bin_prot open Common open Utils open ReadError open Type_class open Bin_prot.Std module Bigstring = struct type t = buf let create = create_buf let of_string str = let len = String.length str in let buf = create len in blit_string_buf str buf ~len; buf let length buf = Array1.dim buf end let expect_exc test_exc f = try ignore (f ()); false with | exc -> test_exc exc let expect_bounds_error f = let test_exc = function | Invalid_argument "index out of bounds" -> true | _ -> false in expect_exc test_exc f let expect_buffer_short f = let exc = Buffer_short in expect_exc ((=) exc) f let expect_read_error exp_re exp_pos f = let test_exc = function | Read_error (re, pos) -> exp_re = re && exp_pos = pos | _ -> false in expect_exc test_exc f let expect_no_error f = try ignore (f ()); true with | _ -> false let check_write_bounds_checks name buf write arg = (name ^ ": negative bound") @? expect_bounds_error (fun () -> write buf ~pos:~-1 arg); (name ^ ": positive bound") @? expect_buffer_short (fun () -> write buf ~pos:(Bigstring.length buf) arg) let check_read_bounds_checks name buf read = (name ^ ": negative bound") @? expect_bounds_error (fun () -> read buf ~pos_ref:(ref ~-1)); (name ^ ": positive bound") @? expect_buffer_short (fun () -> read buf ~pos_ref:(ref (Bigstring.length buf))) let check_write_result name buf pos write arg exp_len = let res_pos = write buf ~pos arg in sprintf "%s: returned wrong write position (%d, expected %d)" name res_pos (pos + exp_len) @? (res_pos = pos + exp_len) let check_read_result name buf pos read exp_ret exp_len = let pos_ref = ref pos in (name ^ ": returned wrong result") @? (read buf ~pos_ref = exp_ret); sprintf "%s: returned wrong read position (%d, expected %d)" name !pos_ref (pos + exp_len) @? (!pos_ref - pos = exp_len) let check_all_args tp_name read write buf args = let write_name = "write_" ^ tp_name ^ " " in let read_name = "read_" ^ tp_name ^ " " in let buf_len = Bigstring.length buf in let act (arg, str_arg, arg_len) = let write_name_arg = write_name ^ str_arg in let read_name_arg = read_name ^ str_arg in for pos = 0 to 8 do check_write_bounds_checks write_name buf write arg; check_read_bounds_checks read_name buf read; check_write_result write_name_arg buf pos write arg arg_len; check_read_result read_name_arg buf pos read arg arg_len; done; (write_name_arg ^ ": write failed near bound") @? expect_no_error (fun () -> write buf ~pos:(buf_len - arg_len) arg); (read_name_arg ^ ": read failed near bound") @? expect_no_error (fun () -> if read buf ~pos_ref:(ref (buf_len - arg_len)) <> arg then failwith (read_name_arg ^ ": read near bound returned wrong result")); let small_buf = Array1.sub buf 0 (buf_len - 1) in (write_name_arg ^ ": write exceeds bound") @? expect_buffer_short (fun () -> write small_buf ~pos:(buf_len - arg_len) arg); (read_name_arg ^ ": read exceeds bound") @? expect_buffer_short (fun () -> read small_buf ~pos_ref:(ref (buf_len - arg_len))) in List.iter act args let mk_buf n = let bstr = Bigstring.create n in for i = 0 to n - 1 do bstr.{i} <- '\255' done; bstr let check_all extra_buf_size tp_name read write args = let buf_len = extra_buf_size + 8 in let buf = mk_buf buf_len in match args with | [] -> assert false | (arg, _, _) :: _ -> let write_name = "write_" ^ tp_name in check_write_bounds_checks write_name buf write arg; let read_name = "read_" ^ tp_name in check_read_bounds_checks read_name buf read; check_all_args tp_name read write buf args let random_string n = let str = String.create n in for i = 0 to n - 1 do str.[i] <- Char.chr (Random.int 256); done; str let mk_int_test ~n ~len = n, Printf.sprintf "%x" n, len let mk_nat0_test ~n ~len = Nat0.of_int n, Printf.sprintf "%x" n, len let mk_float_test n = n, Printf.sprintf "%g" n, 8 let mk_int32_test ~n ~len = n, Printf.sprintf "%lx" n, len let mk_int64_test ~n ~len = n, Printf.sprintf "%Lx" n, len let mk_nativeint_test ~n ~len = n, Printf.sprintf "%nx" n, len let mk_gen_float_vec tp n = let vec = Array1.create tp fortran_layout n in for i = 1 to n do vec.{i} <- float i done; vec let mk_float32_vec = mk_gen_float_vec float32 let mk_float64_vec = mk_gen_float_vec float64 let mk_bigstring n = let bstr = Array1.create char c_layout n in for i = 0 to n - 1 do bstr.{i} <- Char.chr (Random.int 256) done; bstr let mk_gen_float_mat tp m n = let mat = Array2.create tp fortran_layout m n in let fn = float m in for c = 1 to n do let ofs = float (c - 1) *. fn in for r = 1 to m do mat.{r, c} <- ofs +. float r done; done; mat let mk_float32_mat = mk_gen_float_mat float32 let mk_float64_mat = mk_gen_float_mat float64 module type SPEC = sig val kind : string end module type Reader_spec = sig open Read_ml val bin_read_unit : unit reader val bin_read_bool : bool reader val bin_read_string : string reader val bin_read_char : char reader val bin_read_int : int reader val bin_read_nat0 : Nat0.t reader val bin_read_float : float reader val bin_read_int32 : int32 reader val bin_read_int64 : int64 reader val bin_read_nativeint : nativeint reader val bin_read_ref : ('a, 'a ref) reader1 val bin_read_lazy : ('a, 'a lazy_t) reader1 val bin_read_option : ('a, 'a option) reader1 val bin_read_pair : ('a, 'b, 'a * 'b) reader2 val bin_read_triple : ('a, 'b, 'c, 'a * 'b * 'c) reader3 val bin_read_list : ('a, 'a list) reader1 val bin_read_array : ('a, 'a array) reader1 val bin_read_hashtbl : ('a, 'b, ('a, 'b) Hashtbl.t) reader2 val bin_read_float32_vec : vec32 reader val bin_read_float64_vec : vec64 reader val bin_read_vec : vec reader val bin_read_float32_mat : mat32 reader val bin_read_float64_mat : mat64 reader val bin_read_mat : mat reader val bin_read_bigstring : buf reader val bin_read_float_array : float array reader val bin_read_variant_tag : [> ] reader val bin_read_int_64bit : int reader val bin_read_int64_bits : int64 reader val bin_read_network16_int : int reader val bin_read_network32_int : int reader val bin_read_network32_int32 : int32 reader val bin_read_network64_int : int reader val bin_read_network64_int64 : int64 reader end module type Writer_spec = sig open Write_ml val bin_write_unit : unit writer val bin_write_bool : bool writer val bin_write_string : string writer val bin_write_char : char writer val bin_write_int : int writer val bin_write_nat0 : Nat0.t writer val bin_write_float : float writer val bin_write_int32 : int32 writer val bin_write_int64 : int64 writer val bin_write_nativeint : nativeint writer val bin_write_ref : ('a, 'a ref) writer1 val bin_write_lazy : ('a, 'a lazy_t) writer1 val bin_write_option : ('a, 'a option) writer1 val bin_write_pair : ('a, 'b, 'a * 'b) writer2 val bin_write_triple : ('a, 'b, 'c, 'a * 'b * 'c) writer3 val bin_write_list : ('a, 'a list) writer1 val bin_write_array : ('a, 'a array) writer1 val bin_write_hashtbl : ('a, 'b, ('a, 'b) Hashtbl.t) writer2 val bin_write_float32_vec : vec32 writer val bin_write_float64_vec : vec64 writer val bin_write_vec : vec writer val bin_write_float32_mat : mat32 writer val bin_write_float64_mat : mat64 writer val bin_write_mat : mat writer val bin_write_bigstring : buf writer val bin_write_float_array : float array writer val bin_write_variant_tag : [> ] writer val bin_write_int_64bit : int writer val bin_write_int64_bits : int64 writer val bin_write_network16_int : int writer val bin_write_network32_int : int writer val bin_write_network32_int32 : int32 writer val bin_write_network64_int : int writer val bin_write_network64_int64 : int64 writer end module Make (Spec : SPEC) (Read : Reader_spec) (Write : Writer_spec) = struct let test = "Bin_prot_" ^ Spec.kind >::: [ "unit" >:: (fun () -> check_all 1 "unit" Read.bin_read_unit Write.bin_write_unit [ ((), "()", 1); ]; ); "bool" >:: (fun () -> check_all 1 "bool" Read.bin_read_bool Write.bin_write_bool [ (true, "true", 1); (false, "false", 1); ]; ); "string" >:: (fun () -> check_all 66000 "string" Read.bin_read_string Write.bin_write_string [ ("", "\"\"", 1); (random_string 1, "random 1", 1 + 1); (random_string 10, "random 10", 10 + 1); (random_string 127, "random 127", 127 + 1); (random_string 128, "long 128", 128 + 3); (random_string 65535, "long 65535", 65535 + 3); (random_string 65536, "long 65536", 65536 + 5); ]; if Sys.word_size = 32 then let bad_buf = Bigstring.of_string "\253\252\255\255\000" in "String_too_long" @? expect_read_error String_too_long 0 (fun () -> Read.bin_read_string bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\253\251\255\255\000" in "StringMaximimum" @? expect_buffer_short (fun () -> Read.bin_read_string bad_buf ~pos_ref:(ref 0)) else let bad_buf = Bigstring.of_string "\252\248\255\255\255\255\255\255\001" in "String_too_long" @? expect_read_error String_too_long 0 (fun () -> Read.bin_read_string bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\252\247\255\255\255\255\255\255\001" in "StringMaximimum" @? expect_buffer_short (fun () -> Read.bin_read_string bad_buf ~pos_ref:(ref 0)) ); "char" >:: (fun () -> check_all 1 "char" Read.bin_read_char Write.bin_write_char [ ('x', "x", 1); ('y', "y", 1); ]; ); "int" >:: (fun () -> let small_int_tests = [ mk_int_test ~n:~-0x01 ~len:2; mk_int_test ~n: 0x00 ~len:1; mk_int_test ~n: 0x01 ~len:1; mk_int_test ~n:0x7e ~len:1; mk_int_test ~n:0x7f ~len:1; mk_int_test ~n:0x80 ~len:3; mk_int_test ~n:0x81 ~len:3; mk_int_test ~n:0x7ffe ~len:3; mk_int_test ~n:0x7fff ~len:3; mk_int_test ~n:0x8000 ~len:5; mk_int_test ~n:0x8001 ~len:5; mk_int_test ~n:0x3ffffffe ~len:5; mk_int_test ~n:0x3fffffff ~len:5; mk_int_test ~n:~-0x7f ~len:2; mk_int_test ~n:~-0x80 ~len:2; mk_int_test ~n:~-0x81 ~len:3; mk_int_test ~n:~-0x82 ~len:3; mk_int_test ~n:~-0x7fff ~len:3; mk_int_test ~n:~-0x8000 ~len:3; mk_int_test ~n:~-0x8001 ~len:5; mk_int_test ~n:~-0x8002 ~len:5; mk_int_test ~n:~-0x40000001 ~len:5; mk_int_test ~n:~-0x40000000 ~len:5; ] in let all_int_tests = if Sys.word_size = 32 then small_int_tests else mk_int_test ~n:(int_of_string "0x7ffffffe") ~len:5 :: mk_int_test ~n:(int_of_string "0x7fffffff") ~len:5 :: mk_int_test ~n:(int_of_string "0x80000000") ~len:9 :: mk_int_test ~n:(int_of_string "0x80000001") ~len:9 :: mk_int_test ~n:max_int ~len:9 :: mk_int_test ~n:(int_of_string "-0x000000007fffffff") ~len:5 :: mk_int_test ~n:(int_of_string "-0x0000000080000000") ~len:5 :: mk_int_test ~n:(int_of_string "-0x0000000080000001") ~len:9 :: mk_int_test ~n:(int_of_string "-0x0000000080000002") ~len:9 :: mk_int_test ~n:min_int ~len:9 :: small_int_tests in check_all 9 "int" Read.bin_read_int Write.bin_write_int all_int_tests; let bad_buf = Bigstring.of_string "\132" in "Int_code" @? expect_read_error Int_code 0 (fun () -> Read.bin_read_int bad_buf ~pos_ref:(ref 0)); if Sys.word_size = 32 then let bad_buf = Bigstring.of_string "\253\255\255\255\064" in "Int_overflow (positive)" @? expect_read_error Int_overflow 0 (fun () -> Read.bin_read_int bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\253\255\255\255\191" in "Int_overflow (negative)" @? expect_read_error Int_overflow 0 (fun () -> Read.bin_read_int bad_buf ~pos_ref:(ref 0)) else let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\255\064" in "Int_overflow (positive)" @? expect_read_error Int_overflow 0 (fun () -> Read.bin_read_int bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\255\191" in "Int_overflow (negative)" @? expect_read_error Int_overflow 0 (fun () -> Read.bin_read_int bad_buf ~pos_ref:(ref 0)) ); "nat0" >:: (fun () -> let small_int_tests = [ mk_nat0_test ~n:0x00 ~len:1; mk_nat0_test ~n:0x01 ~len:1; mk_nat0_test ~n:0x7e ~len:1; mk_nat0_test ~n:0x7f ~len:1; mk_nat0_test ~n:0x80 ~len:3; mk_nat0_test ~n:0x81 ~len:3; mk_nat0_test ~n:0x7fff ~len:3; mk_nat0_test ~n:0x8000 ~len:3; mk_nat0_test ~n:0xffff ~len:3; mk_nat0_test ~n:0x10000 ~len:5; mk_nat0_test ~n:0x10001 ~len:5; mk_nat0_test ~n:0x3ffffffe ~len:5; mk_nat0_test ~n:0x3fffffff ~len:5; ] in let all_int_tests = if Sys.word_size = 32 then small_int_tests else mk_nat0_test ~n:(int_of_string "0x7fffffff") ~len:5 :: mk_nat0_test ~n:(int_of_string "0x80000000") ~len:5 :: mk_nat0_test ~n:(int_of_string "0xffffffff") ~len:5 :: mk_nat0_test ~n:(int_of_string "0x100000000") ~len:9 :: mk_nat0_test ~n:(int_of_string "0x100000001") ~len:9 :: mk_nat0_test ~n:max_int ~len:9 :: small_int_tests in check_all 9 "nat0" Read.bin_read_nat0 Write.bin_write_nat0 all_int_tests; let bad_buf = Bigstring.of_string "\128" in "Nat0_code" @? expect_read_error Nat0_code 0 (fun () -> Read.bin_read_nat0 bad_buf ~pos_ref:(ref 0)); if Sys.word_size = 32 then let bad_buf = Bigstring.of_string "\253\255\255\255\064" in "Nat0_overflow" @? expect_read_error Nat0_overflow 0 (fun () -> Read.bin_read_nat0 bad_buf ~pos_ref:(ref 0)) else let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\255\064" in "Nat0_overflow" @? expect_read_error Nat0_overflow 0 (fun () -> Read.bin_read_nat0 bad_buf ~pos_ref:(ref 0)) ); "float" >:: (fun () -> let float_tests = [ mk_float_test 0.; mk_float_test (-0.); mk_float_test (-1.); mk_float_test 1.; mk_float_test infinity; mk_float_test (-.infinity); mk_float_test 1e-310; (* subnormal *) mk_float_test (-1e-310); (* subnormal *) mk_float_test 3.141595; ] in check_all 8 "float" Read.bin_read_float Write.bin_write_float float_tests ); "int32" >:: (fun () -> let int32_tests = [ mk_int32_test ~n:(-0x01l) ~len:2; mk_int32_test ~n: 0x00l ~len:1; mk_int32_test ~n: 0x01l ~len:1; mk_int32_test ~n:0x7el ~len:1; mk_int32_test ~n:0x7fl ~len:1; mk_int32_test ~n:0x80l ~len:3; mk_int32_test ~n:0x81l ~len:3; mk_int32_test ~n:0x7ffel ~len:3; mk_int32_test ~n:0x7fffl ~len:3; mk_int32_test ~n:0x8000l ~len:5; mk_int32_test ~n:0x8001l ~len:5; mk_int32_test ~n:0x7ffffffel ~len:5; mk_int32_test ~n:0x7fffffffl ~len:5; mk_int32_test ~n:(-0x7fl) ~len:2; mk_int32_test ~n:(-0x80l) ~len:2; mk_int32_test ~n:(-0x81l) ~len:3; mk_int32_test ~n:(-0x82l) ~len:3; mk_int32_test ~n:(-0x7fffl) ~len:3; mk_int32_test ~n:(-0x8000l) ~len:3; mk_int32_test ~n:(-0x8001l) ~len:5; mk_int32_test ~n:(-0x8002l) ~len:5; mk_int32_test ~n:(-0x80000001l) ~len:5; mk_int32_test ~n:(-0x80000000l) ~len:5; ] in check_all 5 "int32" Read.bin_read_int32 Write.bin_write_int32 int32_tests; let bad_buf = Bigstring.of_string "\132" in "Int32_code" @? expect_read_error Int32_code 0 (fun () -> Read.bin_read_int32 bad_buf ~pos_ref:(ref 0)) ); "int64" >:: (fun () -> let int64_tests = [ mk_int64_test ~n:(-0x01L) ~len:2; mk_int64_test ~n: 0x00L ~len:1; mk_int64_test ~n: 0x01L ~len:1; mk_int64_test ~n:0x7eL ~len:1; mk_int64_test ~n:0x7fL ~len:1; mk_int64_test ~n:0x80L ~len:3; mk_int64_test ~n:0x81L ~len:3; mk_int64_test ~n:0x7ffeL ~len:3; mk_int64_test ~n:0x7fffL ~len:3; mk_int64_test ~n:0x8000L ~len:5; mk_int64_test ~n:0x8001L ~len:5; mk_int64_test ~n:0x7ffffffeL ~len:5; mk_int64_test ~n:0x7fffffffL ~len:5; mk_int64_test ~n:0x80000000L ~len:9; mk_int64_test ~n:0x80000001L ~len:9; mk_int64_test ~n:0x7ffffffffffffffeL ~len:9; mk_int64_test ~n:0x7fffffffffffffffL ~len:9; mk_int64_test ~n:(-0x7fL) ~len:2; mk_int64_test ~n:(-0x80L) ~len:2; mk_int64_test ~n:(-0x81L) ~len:3; mk_int64_test ~n:(-0x82L) ~len:3; mk_int64_test ~n:(-0x7fffL) ~len:3; mk_int64_test ~n:(-0x8000L) ~len:3; mk_int64_test ~n:(-0x8001L) ~len:5; mk_int64_test ~n:(-0x8002L) ~len:5; mk_int64_test ~n:(-0x7fffffffL) ~len:5; mk_int64_test ~n:(-0x80000000L) ~len:5; mk_int64_test ~n:(-0x80000001L) ~len:9; mk_int64_test ~n:(-0x80000002L) ~len:9; mk_int64_test ~n:(-0x8000000000000001L) ~len:9; mk_int64_test ~n:(-0x8000000000000000L) ~len:9; ] in check_all 9 "int64" Read.bin_read_int64 Write.bin_write_int64 int64_tests; let bad_buf = Bigstring.of_string "\132" in "Int64_code" @? expect_read_error Int64_code 0 (fun () -> Read.bin_read_int64 bad_buf ~pos_ref:(ref 0)) ); "nativeint" >:: (fun () -> let small_nativeint_tests = [ mk_nativeint_test ~n:(-0x01n) ~len:2; mk_nativeint_test ~n: 0x00n ~len:1; mk_nativeint_test ~n: 0x01n ~len:1; mk_nativeint_test ~n:0x7en ~len:1; mk_nativeint_test ~n:0x7fn ~len:1; mk_nativeint_test ~n:0x80n ~len:3; mk_nativeint_test ~n:0x81n ~len:3; mk_nativeint_test ~n:0x7ffen ~len:3; mk_nativeint_test ~n:0x7fffn ~len:3; mk_nativeint_test ~n:0x8000n ~len:5; mk_nativeint_test ~n:0x8001n ~len:5; mk_nativeint_test ~n:0x7ffffffen ~len:5; mk_nativeint_test ~n:0x7fffffffn ~len:5; mk_nativeint_test ~n:(-0x7fn) ~len:2; mk_nativeint_test ~n:(-0x80n) ~len:2; mk_nativeint_test ~n:(-0x81n) ~len:3; mk_nativeint_test ~n:(-0x82n) ~len:3; mk_nativeint_test ~n:(-0x7fffn) ~len:3; mk_nativeint_test ~n:(-0x8000n) ~len:3; mk_nativeint_test ~n:(-0x8001n) ~len:5; mk_nativeint_test ~n:(-0x8002n) ~len:5; mk_nativeint_test ~n:(-0x7fffffffn) ~len:5; mk_nativeint_test ~n:(-0x80000000n) ~len:5; ] in let nativeint_tests = if Sys.word_size = 32 then small_nativeint_tests else mk_nativeint_test ~n:0x80000000n ~len:9 :: mk_nativeint_test ~n:0x80000001n ~len:9 :: mk_nativeint_test ~n:(-0x80000001n) ~len:9 :: mk_nativeint_test ~n:(-0x80000002n) ~len:9 :: mk_nativeint_test ~n:(Nativeint.of_string "0x7ffffffffffffffe") ~len:9 :: mk_nativeint_test ~n:(Nativeint.of_string "0x7fffffffffffffff") ~len:9 :: mk_nativeint_test ~n:(Nativeint.of_string "-0x8000000000000001") ~len:9 :: mk_nativeint_test ~n:(Nativeint.of_string "-0x8000000000000000") ~len:9 :: small_nativeint_tests in let size = if Sys.word_size = 32 then 5 else 9 in check_all size "nativeint" Read.bin_read_nativeint Write.bin_write_nativeint nativeint_tests; let bad_buf = Bigstring.of_string "\251" in "Nativeint_code" @? expect_read_error Nativeint_code 0 (fun () -> Read.bin_read_nativeint bad_buf ~pos_ref:(ref 0)); if Sys.word_size = 32 then let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\255\255" in "Nativeint_code (overflow)" @? expect_read_error Nativeint_code 0 (fun () -> Read.bin_read_nativeint bad_buf ~pos_ref:(ref 0)) ); "ref" >:: (fun () -> check_all 1 "ref" (Read.bin_read_ref Read.bin_read_int) (Write.bin_write_ref Write.bin_write_int) [(ref 42, "ref 42", 1)]; ); "option" >:: (fun () -> check_all 2 "option" (Read.bin_read_option Read.bin_read_int) (Write.bin_write_option Write.bin_write_int) [ (Some 42, "Some 42", 2); (None, "None", 1); ]; ); "pair" >:: (fun () -> check_all 9 "pair" (Read.bin_read_pair Read.bin_read_float Read.bin_read_int) (Write.bin_write_pair Write.bin_write_float Write.bin_write_int) [((3.141, 42), "(3.141, 42)", 9)]; ); "triple" >:: (fun () -> check_all 14 "triple" (Read.bin_read_triple Read.bin_read_float Read.bin_read_int Read.bin_read_string) (Write.bin_write_triple Write.bin_write_float Write.bin_write_int Write.bin_write_string) [((3.141, 42, "test"), "(3.141, 42, \"test\")", 14)]; ); "list" >:: (fun () -> check_all 12 "list" (Read.bin_read_list Read.bin_read_int) (Write.bin_write_list Write.bin_write_int) [ ([42; -1; 200; 33000], "[42; -1; 200; 33000]", 12); ([], "[]", 1); ]; ); "array" >:: (fun () -> let bin_read_int_array = Read.bin_read_array Read.bin_read_int in check_all 12 "array" bin_read_int_array (Write.bin_write_array Write.bin_write_int) [ ([| 42; -1; 200; 33000 |], "[|42; -1; 200; 33000|]", 12); ([||], "[||]", 1); ]; if Sys.word_size = 32 then let bad_buf = Bigstring.of_string "\253\000\000\064\000" in "Array_too_long" @? expect_read_error Array_too_long 0 (fun () -> bin_read_int_array bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\253\255\255\063\000" in "ArrayMaximimum" @? expect_buffer_short (fun () -> bin_read_int_array bad_buf ~pos_ref:(ref 0)) else let bad_buf = Bigstring.of_string "\252\000\000\000\000\000\000\064\000" in "Array_too_long" @? expect_read_error Array_too_long 0 (fun () -> bin_read_int_array bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\063\000" in "ArrayMaximimum" @? expect_buffer_short (fun () -> bin_read_int_array bad_buf ~pos_ref:(ref 0)) ); "float_array" >:: (fun () -> check_all 33 "float_array" Read.bin_read_float_array Write.bin_write_float_array [ ([| 42.; -1.; 200.; 33000. |], "[|42.; -1.; 200.; 33000.|]", 33); ([||], "[||]", 1); ]; if Sys.word_size = 32 then let bad_buf = Bigstring.of_string "\253\000\000\032\000" in "Array_too_long (float)" @? expect_read_error Array_too_long 0 (fun () -> Read.bin_read_float_array bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\253\255\255\031\000" in "ArrayMaximimum (float)" @? expect_buffer_short (fun () -> Read.bin_read_float_array bad_buf ~pos_ref:(ref 0)) else let bad_buf = Bigstring.of_string "\252\000\000\000\000\000\000\064\000" in "Array_too_long (float)" @? expect_read_error Array_too_long 0 (fun () -> Read.bin_read_float_array bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\063\000" in "ArrayMaximimum (float)" @? expect_buffer_short (fun () -> Read.bin_read_float_array bad_buf ~pos_ref:(ref 0)) ); "hashtbl" >:: (fun () -> let bindings = List.rev [(42, 3.); (17, 2.); (42, 4.)] in let htbl = Hashtbl.create (List.length bindings) in List.iter (fun (k, v) -> Hashtbl.add htbl k v) bindings; check_all 28 "hashtbl" (Read.bin_read_hashtbl Read.bin_read_int Read.bin_read_float) (Write.bin_write_hashtbl Write.bin_write_int Write.bin_write_float) [ (htbl, "[(42, 3.); (17, 2.); (42, 4.)]", 28); (Hashtbl.create 0, "[]", 1) ]; ); "float32_vec" >:: (fun () -> let n = 128 in let header = 3 in let size = header + n * 4 in let vec = mk_float32_vec n in check_all size "float32_vec" Read.bin_read_float32_vec Write.bin_write_float32_vec [ (vec, "[| ... |]", size); (mk_float32_vec 0, "[||]", 1); ] ); "float64_vec" >:: (fun () -> let n = 127 in let header = 1 in let size = header + n * 8 in let vec = mk_float64_vec n in check_all size "float64_vec" Read.bin_read_float64_vec Write.bin_write_float64_vec [ (vec, "[| ... |]", size); (mk_float64_vec 0, "[||]", 1); ] ); "vec" >:: (fun () -> let n = 128 in let header = 3 in let size = header + n * 8 in let vec = mk_float64_vec n in check_all size "vec" Read.bin_read_vec Write.bin_write_vec [ (vec, "[| ... |]", size); (mk_float64_vec 0, "[||]", 1); ] ); "float32_mat" >:: (fun () -> let m = 128 in let n = 127 in let header = 3 + 1 in let size = header + m * n * 4 in let mat = mk_float32_mat m n in check_all size "float32_mat" Read.bin_read_float32_mat Write.bin_write_float32_mat [ (mat, "[| ... |]", size); (mk_float32_mat 0 0, "[||]", 2); ] ); "float64_mat" >:: (fun () -> let m = 10 in let n = 12 in let header = 1 + 1 in let size = header + m * n * 8 in let mat = mk_float64_mat m n in check_all size "float64_mat" Read.bin_read_float64_mat Write.bin_write_float64_mat [ (mat, "[| ... |]", size); (mk_float64_mat 0 0, "[||]", 2); ] ); "mat" >:: (fun () -> let m = 128 in let n = 128 in let header = 3 + 3 in let size = header + m * n * 8 in let mat = mk_float64_mat m n in check_all size "mat" Read.bin_read_mat Write.bin_write_mat [ (mat, "[| ... |]", size); (mk_float64_mat 0 0, "[||]", 2); ] ); "bigstring" >:: (fun () -> let n = 128 in let header = 3 in let size = header + n in let bstr = mk_bigstring n in check_all size "bigstring" Read.bin_read_bigstring Write.bin_write_bigstring [ (bstr, "[| ... |]", size); (mk_bigstring 0, "[||]", 1); ] ); "variant_tag" >:: (fun () -> check_all 4 "variant_tag" Read.bin_read_variant_tag Write.bin_write_variant_tag [ (`Foo, "`Foo", 4); (`Bar, "`Bar", 4); ]; let bad_buf = Bigstring.of_string "\000\000\000\000" in "Variant_tag" @? expect_read_error Variant_tag 0 (fun () -> Read.bin_read_variant_tag bad_buf ~pos_ref:(ref 0)) ); "int64_bits" >:: (fun () -> check_all 8 "int64_bits" Read.bin_read_int64_bits Write.bin_write_int64_bits [ (Int64.min_int, "min_int", 8); (Int64.add Int64.min_int Int64.one, "min_int + 1", 8); (Int64.minus_one, "-1", 8); (Int64.zero, "0", 8); (Int64.one, "1", 8); (Int64.sub Int64.max_int Int64.one, "max_int - 1", 8); (Int64.max_int, "max_int", 8); ]; ); "int_64bit" >:: (fun () -> check_all 8 "int_64bit" Read.bin_read_int_64bit Write.bin_write_int_64bit [ (min_int, "min_int", 8); (min_int + 1, "min_int + 1", 8); (-1, "-1", 8); (0, "0", 8); (1, "1", 8); (max_int - 1, "max_int - 1", 8); (max_int, "max_int", 8); ]; let bad_buf_max = bin_dump bin_int64_bits.writer (Int64.succ (Int64.of_int max_int)) in "Int_overflow (positive)" @? expect_read_error Int_overflow 0 (fun () -> Read.bin_read_int_64bit bad_buf_max ~pos_ref:(ref 0)); let bad_buf_min = bin_dump bin_int64_bits.writer (Int64.pred (Int64.of_int min_int)) in "Int_overflow (negative)" @? expect_read_error Int_overflow 0 (fun () -> Read.bin_read_int_64bit bad_buf_min ~pos_ref:(ref 0)); ); "network16_int" >:: (fun () -> check_all 2 "network16_int" Read.bin_read_network16_int Write.bin_write_network16_int [ (* No negative numbers - ambiguous on 64bit platforms *) (0, "0", 2); (1, "1", 2); ]; ); "network32_int" >:: (fun () -> check_all 4 "network32_int" Read.bin_read_network32_int Write.bin_write_network32_int [ (* No negative numbers - ambiguous on 64bit platforms *) (0, "0", 4); (1, "1", 4); ]; ); "network32_int32" >:: (fun () -> check_all 4 "network32_int32" Read.bin_read_network32_int32 Write.bin_write_network32_int32 [ (-1l, "-1", 4); (0l, "0", 4); (1l, "1", 4); ]; ); "network64_int" >:: (fun () -> check_all 8 "network64_int" Read.bin_read_network64_int Write.bin_write_network64_int [ (-1, "-1", 8); (0, "0", 8); (1, "1", 8); ]; ); "network64_int64" >:: (fun () -> check_all 8 "network64_int64" Read.bin_read_network64_int64 Write.bin_write_network64_int64 [ (-1L, "-1", 8); (0L, "0", 8); (1L, "1", 8); ]; ); ] end module ML = Make (struct let kind = "ml" end) (Read_ml) (Write_ml) module C = Make (struct let kind = "c" end) (Read_c) (Write_c) module Common = struct type tuple = float * string * int64 with bin_io type 'a record = { a : int; b : 'a; c : 'b. 'b option } with bin_io type 'a singleton_record = { y : 'a } with bin_io type 'a sum = Foo | Bar of int | Bla of 'a * string with bin_io type 'a variant = [ `Foo | `Bar of int | `Bla of 'a * string ] with bin_io type 'a poly_app = (tuple * int singleton_record * 'a record) variant sum list with bin_io type 'a rec_t1 = RecFoo1 of 'a rec_t2 and 'a rec_t2 = RecFoo2 of 'a poly_app * 'a rec_t1 | RecNone with bin_io type 'a poly_id = 'a rec_t1 with bin_io type el = float poly_id with bin_io type els = el array with bin_io let test = "Bin_prot_common" >::: [ "Utils.bin_dump" >:: (fun () -> let el = let record = { a = 17; b = 2.78; c = None } in let arg = (3.1, "foo", 42L), { y = 4321 }, record in let variant = `Bla (arg, "fdsa") in let sum = Bla (variant, "asdf") in let poly_app = [ sum ] in RecFoo1 (RecFoo2 (poly_app, RecFoo1 RecNone)) in let els = Array.create 10 el in let buf = bin_dump ~header:true bin_els.writer els in let pos_ref = ref 0 in let els_len = Read_ml.bin_read_int_64bit buf ~pos_ref in "pos_ref for length incorrect" @? (!pos_ref = 8); "els_len disagrees with bin_size" @? (els_len = bin_size_els els); let new_els = bin_read_els buf ~pos_ref in "new_els and els not equal" @? (els = new_els) ); ] end bin_prot-109.30.00/lib_test/bin_prot_test_nonrec.ml000066400000000000000000000007271216015522300222210ustar00rootroot00000000000000open Bin_prot.Std type t = float with bin_io module M : sig type t = float with bin_io end = struct type nonrec t = t with bin_io end module M1 : sig type t = float list with bin_io end = struct type nonrec t = t list with bin_io end module M2 : sig type nonrec t = t list with bin_io end = struct type nonrec t = t list with bin_io end module M3 : sig type nonrec t = [ `A of t ] with bin_io end = struct type nonrec t = [ `A of t ] with bin_io end bin_prot-109.30.00/lib_test/example.ml000066400000000000000000000027241216015522300174340ustar00rootroot00000000000000open Bin_prot.Std module type S = sig end include (struct type t = int with bin_io end : S) include (struct type t = int32 with bin_io end : S) include (struct type t = int64 with bin_io end : S) include (struct type t = nativeint with bin_io end : S) include (struct type t = float with bin_io end : S) include (struct type t = char with bin_io end : S) include (struct type t = int list with bin_io end : S) include (struct type t = float array with bin_io end : S) include (struct type t = int64 array with bin_io end : S) include (struct type t = int * float * char with bin_io end : S) include (struct type t = A | B with bin_io type u = C | D | E of t with bin_io end : S) include (struct type t = [ `A | `B ] with bin_io type u = [ `C | `D | `E of t ] with bin_io end : S) include (struct type a = [ `A1 | `A2 ] with bin_io type b = [ `B1 | `B2 ] with bin_io type t = [ a | b ] with bin_io end : S) include (struct type t = { foo : char; bar : int; baz : string; } with bin_io end : S) include (struct type 'a t = 'a with bin_io end : S) include (struct type 'a t = 'a * int with bin_io end : S) include (struct type ('a, 'b) t = 'a * 'b with bin_io end : S) include (struct type 'a t = 'a constraint 'a = [< `A | `B ] with bin_io type 'a u = [`A] t with bin_io end : S) include (struct type 'a t = { foo : 'a; bar : int; } with bin_io end : S) bin_prot-109.30.00/lib_test/mac_test.ml000066400000000000000000000052301216015522300175730ustar00rootroot00000000000000open Printf open Bin_prot open Common open Bin_prot.Std (* Checks correct behavior for empty types *) type empty with bin_io module type S = sig (* Checks correct behavior for type signatures with variance annotations. *) type +'a t with bin_io end module PolyInhTest = struct type x = [ `X1 | `X2 ] with bin_io type y = [ `Y1 | `Y2 ] with bin_io type xy = [ x | `FOO | `Bar of int * float | y ] with bin_io end type tuple = float * string * int64 with bin_io type 'a record = { a : int; b : 'a; c : 'b. 'b option } with bin_io type 'a singleton_record = { y : 'a } with bin_io type 'a sum = Foo | Bar of int | Bla of 'a * string with bin_io type 'a variant = [ `Foo | `Bar of int | `Bla of 'a * string ] with bin_io type 'a poly_app = (tuple * int singleton_record * 'a record) variant sum list with bin_io type 'a rec_t1 = RecFoo1 of 'a rec_t2 and 'a rec_t2 = RecFoo2 of 'a poly_app * 'a rec_t1 | RecNone with bin_io type 'a poly_id = 'a rec_t1 with bin_io type el = float poly_id with bin_io type els = el array with bin_io let mb = 1024. *. 1024. let main () = (* Allocate buffer (= bigstring) *) let buf = create_buf 10000 in (* Define array of dummy elements to be marshalled *) let el = let record = { a = 17; b = 2.78; c = None } in let arg = (3.1, "foo", 42L), { y = 4321 }, record in let variant = `Bla (arg, "fdsa") in let sum = Bla (variant, "asdf") in let poly_app = [ sum ] in RecFoo1 (RecFoo2 (poly_app, RecFoo1 RecNone)) in let x = Array.create 10 el in let n = 100_000 in (* Write n times *) let t1 = Unix.gettimeofday () in for _i = 1 to n do ignore (bin_write_els buf ~pos:0 x) done; let t2 = Unix.gettimeofday () in let write_time = t2 -. t1 in (* Read n times *) let t1 = Unix.gettimeofday () in for _i = 1 to n do let pos_ref = ref 0 in ignore (bin_read_els buf ~pos_ref) done; let t2 = Unix.gettimeofday () in let read_time = t2 -. t1 in (* Write, read, and verify *) let end_pos = bin_write_els buf ~pos:0 x in let pos_ref = ref 0 in let y = bin_read_els buf ~pos_ref in assert (!pos_ref = end_pos && x = y); (* Print result *) let f_n = float n in let msg_size = float (n * end_pos) in printf "msgs: %d msg length: %d\n\ write time: %.3fs write rate: %9.2f msgs/s write throughput: %.2f MB/s\n\ \ read time: %.3fs read rate: %9.2f msgs/s read throughput: %.2f MB/s\n%!" n end_pos write_time (f_n /. write_time) (msg_size /. write_time /. mb) read_time (f_n /. read_time) (msg_size /. read_time /. mb) let () = try main () with Read_error (err, pos) -> eprintf "Uncaught exception: %s: %d\n%!" (ReadError.to_string err) pos bin_prot-109.30.00/lib_test/microbench.ml000066400000000000000000000030301216015522300201010ustar00rootroot00000000000000module Type_class = Bin_prot.Type_class module Common = Bin_prot.Common open Bin_prot.Std type t = unit with bin_io type t1 = t with bin_io type t2 = t1 with bin_io type t3 = t2 with bin_io type t4 = t3 with bin_io type t5 = t4 with bin_io type t6 = t5 with bin_io type t7 = t6 with bin_io let io { Type_class. writer = { Type_class.write; size; unsafe_write=_ }; reader = { Type_class.read; unsafe_read=_; unsafe_vtag_read=_ }; } v = let buf = Common.create_buf (size v) in let before = Unix.gettimeofday () in for _i = 1 to 10_000_000 do ignore (write buf v ~pos:0 : int) done; Printf.printf "Write took %f sec\n%!" (Unix.gettimeofday () -. before); let before = Unix.gettimeofday () in let pos_ref = ref 0 in for _i=1 to 10_000_000 do pos_ref := 0; ignore (read ~pos_ref buf) done; Printf.printf "read took %f sec\n%!" (Unix.gettimeofday () -. before) let () = print_endline "===== t"; io bin_t (); print_endline "===== t7"; io bin_t7 () (*let mk_buf n = let bstr = Bigstring.create n in for i = 0 to n - 1 do bstr.{i} <- '\255' done; bstr let check_all extra_buf_size tp_name read write args = let buf_len = extra_buf_size + 8 in let buf = mk_buf buf_len in match args with | [] -> assert false | (arg, _, _) :: _ -> let write_name = "write_" ^ tp_name in check_write_bounds_checks write_name buf write arg; let read_name = "read_" ^ tp_name in check_read_bounds_checks read_name buf read; check_all_args tp_name read write buf args *) bin_prot-109.30.00/lib_test/qtest.ml000066400000000000000000000002011216015522300171250ustar00rootroot00000000000000(** Regression test runner. *) let tests = Qtest_lib.Std.Test.tests_of_ounit Test.all let () = Qtest_lib.Std.Runner.main tests bin_prot-109.30.00/lib_test/test.ml000066400000000000000000000002071216015522300167520ustar00rootroot00000000000000open OUnit let all = TestList [ Bin_prot_test.ML.test; Bin_prot_test.C.test; Bin_prot_test.Common.test; ] bin_prot-109.30.00/lib_test/test_runner.ml000066400000000000000000000000701216015522300203410ustar00rootroot00000000000000open OUnit let () = ignore (run_test_tt_main Test.all) bin_prot-109.30.00/myocamlbuild.ml000066400000000000000000000360171216015522300166570ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: fd9cc29348f21d1b87068761320a953d) *) module OASISGettext = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str : ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISExpr = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end # 117 "myocamlbuild.ml" module BaseEnvLight = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let var_get name env = let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff in var_expand (MapString.find name env) let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild * by N. Pouillard and others * * Updated on 2009/02/28 * * Modified by Sylvain Le Gall *) open Ocamlbuild_plugin (* these functions are not really officially exported *) let run_and_read = Ocamlbuild_pack.My_unix.run_and_read let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings let split s ch = let x = ref [] in let rec go s = let pos = String.index s ch in x := (String.before s pos)::!x; go (String.after s (pos + 1)) in try go s with Not_found -> !x let split_nl s = split s '\n' let before_space s = try String.before s (String.index s ' ') with Not_found -> s (* this lists all supported packages *) let find_packages () = List.map before_space (split_nl & run_and_read "ocamlfind list") (* this is supposed to list available syntaxes, but I don't know how to do it. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] (* ocamlfind command *) let ocamlfind x = S[A"ocamlfind"; x] let dispatch = function | Before_options -> (* by using Before_options one let command line options have an higher priority *) (* on the contrary using After_options will guarantee to have the higher priority *) (* override default commands by ocamlfind ones *) Options.ocamlc := ocamlfind & A"ocamlc"; Options.ocamlopt := ocamlfind & A"ocamlopt"; Options.ocamldep := ocamlfind & A"ocamldep"; Options.ocamldoc := ocamlfind & A"ocamldoc"; Options.ocamlmktop := ocamlfind & A"ocamlmktop" | After_rules -> (* When one link an OCaml library/binary/package, one should use -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; end (find_packages ()); (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) List.iter begin fun syntax -> flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. * Indeed, the default rules add the "threads.cma" or "threads.cmxa" * options when using this tag. When using the "-linkpkg" option with * ocamlfind, this module will then be added twice on the command line. * * To solve this, one approach is to add the "-thread" option when using * the "threads" package using the previous plugin. *) flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) | _ -> () end module MyOCamlbuildBase = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall *) open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler type dir = string type file = string type name = string type tag = string (* # 56 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { lib_ocaml: (name * dir list) list; lib_c: (name * dir * file list) list; flags: (tag list * (spec OASISExpr.choices)) list; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) includes: (dir * dir list) list; } let env_filename = Pathname.basename BaseEnvLight.default_filename let dispatch_combine lst = fun e -> List.iter (fun dispatch -> dispatch e) lst let tag_libstubs nm = "use_lib"^nm^"_stubs" let nm_libstubs nm = nm^"_stubs" let dispatch t e = let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in match e with | Before_options -> let no_trailing_dot s = if String.length s >= 1 && s.[0] = '.' then String.sub s 1 ((String.length s) - 1) else s in List.iter (fun (opt, var) -> try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> Printf.eprintf "W: Cannot get variable %s" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; Options.ext_dll, "ext_dll"; ] | After_rules -> (* Declare OCaml libraries *) List.iter (function | nm, [] -> ocaml_lib nm | nm, dir :: tl -> ocaml_lib ~dir:dir (dir^"/"^nm); List.iter (fun dir -> List.iter (fun str -> flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) ["compile"; "infer_interface"; "doc"]) tl) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; (* Declare C libraries *) List.iter (fun (lib, dir, headers) -> (* Handle C part of library *) flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. *) dep ["link"; "ocaml"; "program"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; dep ["compile"; "ocaml"; "program"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) dep ["compile"; "c"] headers; (* Setup search path for lib *) flag ["link"; "ocaml"; "use_"^lib] (S[A"-I"; P(dir)]); ) t.lib_c; (* Add flags *) List.iter (fun (tags, cond_specs) -> let spec = BaseEnvLight.var_choose cond_specs env in flag tags & spec) t.flags | _ -> () let dispatch_default t = dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch; ] end # 476 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [("bin_prot", ["lib"]); ("pa_bin_prot", ["syntax"])]; lib_c = [ ("bin_prot", "lib", ["lib/common_stubs.h"; "lib/int64_native.h"; "lib/int64_emul.h"]) ]; flags = []; includes = [("lib_test", ["lib"; "syntax"])]; } ;; let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; # 496 "myocamlbuild.ml" (* OASIS_STOP *) let dispatch = function | After_rules -> let env = BaseEnvLight.load () in let system = BaseEnvLight.var_get "system" env in let is_darwin = String.is_prefix "macos" system in let arch_sixtyfour = BaseEnvLight.var_get "arch_sixtyfour" env = "true" in let cpp = "gcc -E -xc -undef -w" in let cpp = if arch_sixtyfour then cpp ^ " -DARCH_SIXTYFOUR" else cpp in let cpp = S [A "-pp"; P cpp] in dep ["ocaml"; "ocamldep"; "mlh"] ["lib/int_codes.mlh"]; flag ["ocamldep"; "ocaml"; "use_pa_bin_prot"] (S [A "-ppopt"; P "syntax/pa_bin_prot.cma"]); flag ["compile"; "ocaml"; "use_pa_bin_prot"] (S [A "-ppopt"; P "syntax/pa_bin_prot.cma"]); flag ["ocamldep"; "ocaml"; "cpp"] cpp; flag ["compile"; "ocaml"; "cpp"] cpp; flag ["doc"; "ocaml"; "cpp"] cpp; if is_darwin then flag ["compile"; "c"] (S [A "-ccopt"; A "-DOS_DARWIN"]); | _ -> () let () = Ocamlbuild_plugin.dispatch (fun hook -> dispatch hook; dispatch_default hook) bin_prot-109.30.00/setup.ml000066400000000000000000005155741216015522300153500ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: ba5a08ea630d41cc96154edfd3166060) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str : ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISContext = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type t = { quiet: bool; info: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: bool; printf: level -> string -> unit; } let printf lvl str = let beg = match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in prerr_endline (beg^str) let default = ref { quiet = false; info = false; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; } let quiet = {!default with quiet = true} let args () = ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), (s_ " Run quietly"); "-info", Arg.Unit (fun () -> default := {!default with info = true}), (s_ " Display information message"); "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), (s_ " Output debug message")] end module OASISString = struct (* # 1 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; if !what_idx = String.length what then true else false let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; if !what_idx = -1 then true else false let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = String.make (String.length s) 'X' in for i = 0 to String.length s - 1 do buf.[i] <- f s.[i] done; buf end module OASISUtils = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) open OASISGettext module MapString = Map.Make(String) let map_string_of_assoc assoc = List.fold_left (fun acc (k, v) -> MapString.add k v acc) MapString.empty assoc module SetString = Set.Make(String) let set_string_add_list st lst = List.fold_left (fun acc e -> SetString.add e acc) st lst let set_string_of_list = set_string_add_list SetString.empty let compare_csl s1 s2 = String.compare (String.lowercase s1) (String.lowercase s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (String.lowercase s1) = (String.lowercase s2) let hash s = Hashtbl.hash (String.lowercase s) end) let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in String.lowercase buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt end module PropList = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) open OASISGettext type name = string exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> Some (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) module Data = struct type t = (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 let clear t = Hashtbl.clear t (* # 71 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) end module Schema = struct type ('ctxt, 'extra) value = { get: Data.t -> string; set: Data.t -> ?context:'ctxt -> string -> unit; help: (unit -> string) option; extra: 'extra; } type ('ctxt, 'extra) t = { name: name; fields: (name, ('ctxt, 'extra) value) Hashtbl.t; order: name Queue.t; name_norm: string -> string; } let create ?(case_insensitive=false) nm = { name = nm; fields = Hashtbl.create 13; order = Queue.create (); name_norm = (if case_insensitive then String.lowercase else fun s -> s); } let add t nm set get extra help = let key = t.name_norm nm in if Hashtbl.mem t.fields key then failwith (Printf.sprintf (f_ "Field '%s' is already defined in schema '%s'") nm t.name); Hashtbl.add t.fields key { set = set; get = get; help = help; extra = extra; }; Queue.add nm t.order let mem t nm = Hashtbl.mem t.fields nm let find t nm = try Hashtbl.find t.fields (t.name_norm nm) with Not_found -> raise (Unknown_field (nm, t.name)) let get t data nm = (find t nm).get data let set t data nm ?context x = (find t nm).set data ?context x let fold f acc t = Queue.fold (fun acc k -> let v = find t k in f acc k v.extra v.help) acc t.order let iter f t = fold (fun () -> f) () t let name t = t.name end module Field = struct type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; get: Data.t -> 'value; sets: Data.t -> ?context:'ctxt -> string -> unit; gets: Data.t -> string; help: (unit -> string) option; extra: 'extra; } let new_id = let last_id = ref 0 in fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) let v = ref None in (* If name is not given, create unique one *) let nm = match name with | Some s -> s | None -> Printf.sprintf "_anon_%d" (new_id ()) in (* Last chance to get a value: the default *) let default () = match default with | Some d -> d | None -> raise (Not_set (nm, Some (s_ "no default value"))) in (* Get data *) let get data = (* Get value *) try (Hashtbl.find data nm) (); match !v with | Some x -> x | None -> default () with Not_found -> default () in (* Set data *) let set data ?context x = let x = match update with | Some f -> begin try f ?context (get data) x with Not_set _ -> x end | None -> x in Hashtbl.replace data nm (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> f | None -> fun ?context s -> failwith (Printf.sprintf (f_ "Cannot parse field '%s' when setting value %S") nm s) in (* Set data, from string *) let sets data ?context s = set ?context data (parse ?context s) in (* Output value as string, if possible *) let print = match print with | Some f -> f | None -> fun _ -> raise (No_printer nm) in (* Get data, as a string *) let gets data = print (get data) in begin match schema with | Some t -> Schema.add t nm sets gets extra help | None -> () end; { set = set; get = get; sets = sets; gets = gets; help = help; extra = extra; } let fset data t ?context x = t.set data ?context x let fget data t = t.get data let fsets data t ?context s = t.sets data ?context s let fgets data t = t.gets data end module FieldRO = struct let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld end end module OASISMessage = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then false else match lvl with | `Debug -> ctxt.debug | `Info -> ctxt.info | _ -> true in Printf.ksprintf (fun str -> if cond then begin ctxt.printf lvl str end) fmt let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt let info ~ctxt fmt = generic_message ~ctxt `Info fmt let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) open OASISGettext type s = string type t = string type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t | VLesser of t | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin (* Compare ascii string, using special meaning for version * related char *) let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 else if is_alpha c then Char.code c else (Char.code c) + 256 in let len1 = String.length v1 in let len2 = String.length v2 in let p = ref 0 in (** Compare ascii part *) let compare_vascii () = let cmp = ref 0 in while !cmp = 0 && !p < len1 && !p < len2 && not (is_digit v1.[!p] && is_digit v2.[!p]) do cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); incr p done; if !cmp = 0 && !p < len1 && !p = len2 then val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else !cmp in (** Compare digit part *) let compare_digit () = let extract_int v p = let start_p = !p in while !p < String.length v && is_digit v.[!p] do incr p done; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr in let i1, tl1 = extract_int v1 (ref !p) in let i2, tl2 = extract_int v2 (ref !p) in i1 - i2, tl1, tl2 in match compare_vascii () with | 0 -> begin match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 else if tl2 <> "" && is_digit tl2.[0] then -1 else version_compare tl1 tl2 | n, _, _ -> n end | n -> n end else begin 0 end let version_of_string str = str let string_of_version t = t let chop t = try let pos = String.rindex t '.' in String.sub t 0 pos with Not_found -> t let rec comparator_apply v op = match op with | VGreater cv -> (version_compare v cv) > 0 | VGreaterEqual cv -> (version_compare v cv) >= 0 | VLesser cv -> (version_compare v cv) < 0 | VLesserEqual cv -> (version_compare v cv) <= 0 | VEqual cv -> (version_compare v cv) = 0 | VOr (op1, op2) -> (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) | VEqual v -> "= "^(string_of_version v) | VLesser v -> "< "^(string_of_version v) | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat p (OASISUtils.varname_of_string (string_of_version v)) in function | VGreater v -> concat "gt" v | VLesser v -> concat "lt" v | VEqual v -> concat "eq" v | VGreaterEqual v -> concat "ge" v | VLesserEqual v -> concat "le" v | VOr (c1, c2) -> (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) let version_0_3_or_after t = comparator_apply t (VGreaterEqual (string_of_version "0.3")) end module OASISLicense = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall *) type license = string type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion type license_dep_5_unit = { license: license; excption: license_exception option; version: license_version; } type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end module OASISTypes = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) type name = string type package_name = string type url = string type unix_dirname = string type unix_filename = string type host_dirname = string type host_filename = string type prog = string type arg = string type args = string list type command_line = (prog * arg list) type findlib_name = string type findlib_full = string type compiled_object = | Byte | Native | Best type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name type tool = | ExternalTool of name | InternalExecutable of name type vcs = | Darcs | Git | Svn | Cvs | Hg | Bzr | Arch | Monotone | OtherVCS of url type plugin_kind = [ `Configure | `Build | `Doc | `Test | `Install | `Extra ] type plugin_data_purpose = [ `Configure | `Build | `Install | `Clean | `Distclean | `Install | `Uninstall | `Test | `Doc | `Extra | `Other of string ] type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list (* # 102 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } type common_section = { cs_name: name; cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } type build_section = { bs_build: bool conditional; bs_install: bool conditional; bs_path: unix_dirname; bs_compiled_object: compiled_object; bs_build_depends: dependency list; bs_build_tools: tool list; bs_c_sources: unix_filename list; bs_data_files: (unix_filename * unix_filename option) list; bs_ccopt: args conditional; bs_cclib: args conditional; bs_dlllib: args conditional; bs_dllpath: args conditional; bs_byteopt: args conditional; bs_nativeopt: args conditional; } type library = { lib_modules: string list; lib_pack: bool; lib_internal_modules: string list; lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; } type executable = { exec_custom: bool; exec_main_is: unix_filename; } type flag = { flag_description: string option; flag_default: bool conditional; } type source_repository = { src_repo_type: vcs; src_repo_location: url; src_repo_browser: url option; src_repo_module: string option; src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; } type test = { test_type: [`Test] plugin; test_command: command_line conditional; test_custom: custom; test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; } type doc_format = | HTML of unix_filename | DocText | PDF | PostScript | Info of unix_filename | DVI | OtherDoc type doc = { doc_type: [`Doc] plugin; doc_custom: custom; doc_build: bool conditional; doc_install: bool conditional; doc_install_dir: unix_filename; doc_title: string; doc_authors: string list; doc_abstract: string option; doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; } type section = | Library of common_section * build_section * library | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc type section_kind = [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; name: package_name; version: OASISVersion.t; license: OASISLicense.t; license_file: unix_filename option; copyrights: string list; maintainers: string list; authors: string list; homepage: url option; synopsis: string; description: string option; categories: url list; conf_type: [`Configure] plugin; conf_custom: custom; build_type: [`Build] plugin; build_custom: custom; install_type: [`Install] plugin; install_custom: custom; uninstall_custom: custom; clean_custom: custom; distclean_custom: custom; files_ab: unix_filename list; sections: section list; plugins: [`Extra] plugin list; schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISUnixPath = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string type host_filename = string type host_dirname = string let current_dir_name = "." let parent_dir_name = ".." let is_current_dir fn = fn = current_dir_name || fn = "" let concat f1 f2 = if is_current_dir f1 then f2 else let f1' = try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 in f1'^"/"^f2 let make = function | hd :: tl -> List.fold_left (fun f p -> concat f p) hd tl | [] -> invalid_arg "OASISUnixPath.make" let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name let basename f = try let pos_start = (String.rindex f '/') + 1 in String.sub f pos_start ((String.length f) - pos_start) with Not_found -> f let chop_extension f = try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in try let last_slash = String.rindex f '/' in if last_slash < last_dot then sub else f with Not_found -> sub with Not_found -> f let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.capitalize base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.uncapitalize base) end module OASISHostPath = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) open Filename module Unix = OASISUnixPath let make = function | [] -> invalid_arg "OASISHostPath.make" | hd :: tl -> List.fold_left Filename.concat hd tl let of_unix ufn = if Sys.os_type = "Unix" then ufn else make (List.map (fun p -> if p = Unix.current_dir_name then current_dir_name else if p = Unix.parent_dir_name then parent_dir_name else p) (OASISString.nsplit ufn '/')) end module OASISSection = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> `Flag, cs | SrcRepo (cs, _) -> `SrcRepo, cs | Test (cs, _) -> `Test, cs | Doc (cs, _) -> `Doc, cs let section_common sct = snd (section_kind_common sct) let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** Key used to identify section *) let section_id sct = let k, cs = section_kind_common sct in k, cs.cs_name let string_of_section sct = let k, nm = section_id sct in (match k with | `Library -> "library" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc") ^" "^nm let section_find id scts = List.find (fun sct -> id = section_id sct) scts module CSection = struct type t = section let id = section_id let compare t1 t2 = compare (id t1) (id t2) let equal t1 t2 = (id t1) = (id t2) let hash t = Hashtbl.hash (id t) end module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) end module OASISBuildSection = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) open OASISTypes let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () | Byte -> false in OASISUnixPath.concat dir (cs.cs_name^(suffix_program ())), if not is_native_exec && not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection type library_name = name type findlib_part_name = name type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t exception InternalLibraryNotFound of library_name exception FindlibPackageNotFound of findlib_name type group_t = | Container of findlib_name * group_t list | Package of (findlib_name * common_section * build_section * library * group_t list) (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists (cs, bs, lib) modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) [modul; OASISUnixPath.uncapitalize_file modul; OASISUnixPath.capitalize_file modul] in (* TODO: we should be able to be able to determine the source for every * files. Hence we should introduce a Module(source: fn) for the fields * Modules and InternalModules *) List.fold_left (fun acc base_fn -> match acc with | `No_sources _ -> begin let file_found = List.fold_left (fun acc ext -> if source_file_exists (base_fn^ext) then (base_fn^ext) :: acc else acc) [] [".ml"; ".mli"; ".mll"; ".mly"] in match file_found with | [] -> acc | lst -> `Sources (base_fn, lst) end | `Sources _ -> acc) (`No_sources possible_base_fn) possible_base_fn let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, _) -> [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; lst in List.map (fun nm -> List.map (fun base_fn -> base_fn ^"."^ext) (find_module nm)) lst in (* The headers that should be compiled along *) let headers = if lib.lib_pack then [] else find_modules lib.lib_modules "cmi" in (* The .cmx that be compiled along *) let cmxs = let should_be_built = (not lib.lib_pack) && (* Do not install .cmx packed submodules *) match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) let acc_nopath = if bs.bs_c_sources <> [] then begin ["lib"^cs.cs_name^"_stubs"^ext_lib] :: ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath end else acc_nopath in (* All the files generated *) List.rev_append (List.rev_map (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) (headers @ cmxs) type data = common_section * build_section * library type tree = | Node of (data option) * (tree MapString.t) | Leaf of data let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = let fndlb_parts cs lib = let name = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in let name = String.concat "." (lib.lib_findlib_containers @ [name]) in name in List.fold_left (fun mp -> function | Library (cs, _, lib) -> begin let lib_name = cs.cs_name in let fndlb_parts = fndlb_parts cs lib in if MapString.mem lib_name mp then failwithf (f_ "The library name '%s' is used more than once.") lib_name; match lib.lib_findlib_parent with | Some lib_name_parent -> MapString.add lib_name (`Unsolved (lib_name_parent, fndlb_parts)) mp | None -> MapString.add lib_name (`Solved fndlb_parts) mp end | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) let fndlb_name_of_lib_name = let rec solve visited mp lib_name lib_name_child = if SetString.mem lib_name visited then failwithf (f_ "Library '%s' is involved in a cycle \ with regard to findlib naming.") lib_name; let visited = SetString.add lib_name visited in try match MapString.find lib_name mp with | `Solved fndlb_nm -> fndlb_nm, mp | `Unsolved (lib_nm_parent, post_fndlb_nm) -> let pre_fndlb_nm, mp = solve visited mp lib_nm_parent lib_name in let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp with Not_found -> failwithf (f_ "Library '%s', which is defined as the findlib parent of \ library '%s', doesn't exist.") lib_name lib_name_child in let mp = MapString.fold (fun lib_name status mp -> match status with | `Solved _ -> (* Solved initialy, no need to go further *) mp | `Unsolved _ -> let _, mp = solve SetString.empty mp lib_name "" in mp) fndlb_parts_of_lib_name fndlb_parts_of_lib_name in MapString.map (function | `Solved fndlb_nm -> fndlb_nm | `Unsolved _ -> assert false) mp in (* Convert an internal library name to a findlib name. *) let findlib_name_of_library_name lib_nm = try MapString.find lib_nm fndlb_name_of_lib_name with Not_found -> raise (InternalLibraryNotFound lib_nm) in (* Add a library to the tree. *) let add sct mp = let fndlb_fullname = let cs, _, _ = sct in let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in let rec add_children nm_lst (children : tree MapString.t) = match nm_lst with | (hd :: tl) -> begin let node = try add_node tl (MapString.find hd children) with Not_found -> (* New node *) new_node tl in MapString.add hd node children end | [] -> (* Should not have a nameless library. *) assert false and add_node tl node = if tl = [] then begin match node with | Node (None, children) -> Node (Some sct, children) | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> (* TODO: allow to merge Package, i.e. * archive(byte) = "foo.cma foo_init.cmo" *) let cs, _, _ = sct in failwithf (f_ "Library '%s' and '%s' have the same findlib name '%s'") cs.cs_name cs'.cs_name fndlb_fullname end else begin match node with | Leaf data -> Node (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> Node (data_opt, add_children tl children) end and new_node = function | [] -> Leaf sct | hd :: tl -> Node (None, MapString.add hd (new_node tl) MapString.empty) in add_children (OASISString.nsplit fndlb_fullname '.') mp in let rec group_of_tree mp = MapString.fold (fun nm node acc -> let cur = match node with | Node (Some (cs, bs, lib), children) -> Package (nm, cs, bs, lib, group_of_tree children) | Node (None, children) -> Container (nm, group_of_tree children) | Leaf (cs, bs, lib) -> Package (nm, cs, bs, lib, []) in cur :: acc) mp [] in let group_mp = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> add (cs, bs, lib) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree group_mp in let library_name_of_findlib_name = Lazy.lazy_from_fun (fun () -> (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty) in let library_name_of_findlib_name fndlb_nm = try MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) with Not_found -> raise (FindlibPackageNotFound fndlb_nm) in groups, findlib_name_of_library_name, library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) function | Container (_, children) -> List.fold_left (fun res grp -> if res = None then root_lib_aux grp else res) None children | Package (_, cs, bs, lib, _) -> Some (cs, bs, lib) in match root_lib_aux grp with | Some res -> res | None -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) let run ~ctxt ?f_exit_code ?(quote=true) cmd args = let cmd = if quote then if Sys.os_type = "Win32" then if String.contains cmd ' ' then (* Double the 1st double quote... win32... sigh *) "\""^(Filename.quote cmd) else cmd else Filename.quote cmd else cmd in let cmdline = String.concat " " (cmd :: args) in info ~ctxt (f_ "Running command '%s'") cmdline; match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> failwithf (f_ "Command '%s' terminated with error code %d") cmdline i | Some f, i -> f i let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in try begin let () = run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) in let chn = open_in fn in let routput = ref [] in begin try while true do routput := (input_line chn) :: !routput done with End_of_file -> () end; close_in chn; Sys.remove fn; List.rev !routput end with e -> (try Sys.remove fn with _ -> ()); raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module OASISFileUtil = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) open OASISGettext let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in if Sys.file_exists dirname then if basename = Filename.current_dir_name then true else List.mem basename (Array.to_list (Sys.readdir dirname)) else false let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) let ( * ) lst1 lst2 = List.flatten (List.map (fun a -> List.map (fun b -> a,b) lst2) lst1) in let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> let acc = (List.map (fun (a,b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) | [e] -> e | [] -> [] in let alternatives = List.map (fun (p,e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in List.find (if case_sensitive then file_exists_case else Sys.file_exists) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> [""] in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true *) let ln = String.length dn in if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then fix_dir (String.sub dn 0 (ln - 1)) else dn let q = Filename.quote (**/**) let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "xcopy" [q src; q tgt; "/E"] | _ -> OASISExec.run ~ctxt "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt in if Sys.file_exists tgt then begin if not (Sys.is_directory tgt) then OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt end else begin mkdir_parent ~ctxt f (Filename.dirname tgt); if not (Sys.file_exists tgt) then begin f tgt; mkdir ~ctxt tgt end end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "rd" [q tgt] | _ -> OASISExec.run ~ctxt "rm" ["-r"; q tgt] end let glob ~ctxt fn = let basename = Filename.basename fn in if String.length basename >= 2 && basename.[0] = '*' && basename.[1] = '.' then begin let ext_len = (String.length basename) - 2 in let ext = String.sub basename 2 ext_len in let dirname = Filename.dirname fn in Array.fold_left (fun acc fn -> try let fn_ext = String.sub fn ((String.length fn) - ext_len) ext_len in if fn_ext = ext then (Filename.concat dirname fn) :: acc else acc with Invalid_argument _ -> acc) [] (Sys.readdir dirname) end else begin if file_exists_case fn then [fn] else [] end end # 2142 "setup.ml" module BaseEnvLight = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let var_get name env = let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff in var_expand (MapString.find name env) let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 2240 "setup.ml" module BaseContext = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseContext.ml" *) open OASISContext let args = args let default = default end module BaseMessage = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall *) open OASISMessage open BaseContext let debug fmt = debug ~ctxt:!default fmt let info fmt = info ~ctxt:!default fmt let warning fmt = warning ~ctxt:!default fmt let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open PropList module MapString = BaseEnvLight.MapString type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine type cli_handle_t = | CLINone | CLIAuto | CLIWith | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list type definition_t = { hide: bool; dump: bool; cli: cli_handle_t; arg_help: string option; group: string option; } let schema = Schema.create "environment" (* Environment data *) let env = Data.create () (* Environment data from file *) let env_from_file = ref MapString.empty (* Lexer for var *) let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try (* TODO: this is a quick hack to allow calling Test.Command * without defining executable name really. I.e. if there is * an exec Executable toto, then $(toto) should be replace * by its real name. It is however useful to have this function * for other variable that depend on the host and should be * written better than that. *) let st = var_lxr (Stream.of_string var) in match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> OASISHostPath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> OASISHostPath.of_unix s | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> String.escaped (var_get nm) | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> String.escaped s | [Genlex.Ident nm] -> var_get nm | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var str e) str; Buffer.contents buff and var_get name = let vl = try Schema.get schema env name with Unknown_field _ as e -> begin try MapString.find name !env_from_file with Not_found -> raise e end in var_expand vl let var_choose ?printer ?name lst = OASISExpr.choose ?printer ?name var_get lst let var_protect vl = let buff = Buffer.create (String.length vl) in String.iter (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff let var_define ?(hide=false) ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> Sys.getenv name); ] in let extra = { hide = hide; dump = dump; cli = cli; arg_help = arg_help; group = group; } in (* Try to find a value that can be defined *) let var_get_low lst = let errors, res = List.fold_left (fun (errors, res) (o, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> errors, res | Failure rsn -> (rsn :: errors), res | e -> (Printexc.to_string e) :: errors, res end else errors, res) ([], None) (List.sort (fun (o1, _) (o2, _) -> Pervasives.compare o2 o1) lst) in match res, errors with | Some v, _ -> v | None, [] -> raise (Not_set (name, None)) | None, lst -> raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = match short_desc with | Some fs -> Some fs | None -> None in let var_get_lst = FieldRO.create ~schema ~name ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context x old_x -> x @ old_x) ?help extra in fun () -> var_expand (var_get_low (var_get_lst env)) let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (dflt ()); fun () -> var_get name end else begin var_define ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt end let var_ignore (e : unit -> string) = () let print_hidden = var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" (fun () -> "false") let var_all () = List.rev (Schema.fold (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else acc) [] schema) let default_filename = BaseEnvLight.default_filename let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () let unload () = env_from_file := MapString.empty; Data.clear env let dump ?(filename=default_filename) () = let chn = open_out_bin filename in let output nm value = Printf.fprintf chn "%s=%S\n" nm value in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try let value = Schema.get schema env nm in output nm value with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; (* End of the dump *) close_out chn let print () = let printable_vars = Schema.fold (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin try let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in (txt, value) :: acc with Not_set _ -> acc end else acc) [] schema in let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) in let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in Printf.printf "\nConfiguration: \n"; List.iter (fun (name,value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in [ "--override", Arg.Tuple ( let rvr = ref "" in let rvl = ref "" in [ Arg.Set_string rvr; Arg.Set_string rvl; Arg.Unit (fun () -> Schema.set schema env ~context:OCommandLine !rvr !rvl) ] ), "var+val Override any configuration variable."; ] @ List.flatten (Schema.fold (fun acc name def short_descr_opt -> let var_set s = Schema.set schema env ~context:OCommandLine name s in let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = match def.arg_help with | Some s -> s | None -> "str" in let default_value = try Printf.sprintf (f_ " [%s]") (Schema.get schema env name) with Not_set _ -> "" in let args = match def.cli with | CLINone -> [] | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIWith -> [ arg_concat "--with-" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseArgExt = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext let parse argv args = (* Simulate command line for Arg *) let current = ref 0 in try Arg.parse_argv ~current:current (Array.concat [[|"none"|]; argv]) (Arg.align args) (failwithf (f_ "Don't know what to do with arguments: '%s'")) (s_ "configure options:") with | Arg.Help txt -> print_endline txt; exit 0 | Arg.Bad txt -> prerr_endline txt; exit 1 end module BaseCheck = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext let prog_best prg prg_lst = var_redefine prg (fun () -> let alternate = List.fold_left (fun res e -> match res with | Some _ -> res | None -> try Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) with Not_found -> None) None prg_lst in match alternate with | Some prg -> prg | None -> raise Not_found) let prog prg = prog_best prg [prg] let prog_opt prg = prog_best prg [prg^".opt"; prg] let ocamlfind = prog "ocamlfind" let version var_prefix cmp fversion () = (* Really compare version provided *) let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in var_redefine ~hide:true var (fun () -> let version_str = match fversion () with | "[Distributed with OCaml]" -> begin try (var_get "ocaml_version") with Not_found -> warning (f_ "Variable ocaml_version not defined, fallback \ to default"); Sys.ocaml_version end | res -> res in let version = OASISVersion.version_of_string version_str in if OASISVersion.comparator_apply version cmp then version_str else failwithf (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") var_prefix (OASISVersion.string_of_comparator cmp) version_str) () let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] let package ?version_comparator pkg () = let var = OASISUtils.varname_concat "pkg_" (OASISUtils.varname_of_string pkg) in let findlib_dir pkg = let dir = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in if Sys.file_exists dir && Sys.is_directory dir then dir else failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir in let vl = var_redefine var (fun () -> findlib_dir pkg) () in ( match version_comparator with | Some ver_cmp -> ignore (version var ver_cmp (fun _ -> package_version pkg) ()) | None -> () ); vl end module BaseOCamlcConfig = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext module SMap = Map.Make(String) let ocamlc = BaseCheck.prog_opt "ocamlc" let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) *) let rec split_field mp lst = match lst with | line :: tl -> let mp = try let pos_semicolon = String.index line ':' in if pos_semicolon > 1 then ( let name = String.sub line 0 pos_semicolon in let linelen = String.length line in let value = if linelen > pos_semicolon + 2 then String.sub line (pos_semicolon + 2) (linelen - pos_semicolon - 2) else "" in SMap.add name value mp ) else ( mp ) with Not_found -> ( mp ) in split_field mp tl | [] -> mp in let cache = lazy (var_protect (Marshal.to_string (split_field SMap.empty (OASISExec.run_read_output ~ctxt:!BaseContext.default (ocamlc ()) ["-config"])) [])) in var_redefine "ocamlc_config_map" ~hide:true ~dump:false (fun () -> (* TODO: update if ocamlc change !!! *) Lazy.force cache) let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = Marshal.from_string (ocamlc_config_map ()) 0 in let chop_version_suffix s = try String.sub s 0 (String.index s '+') with _ -> s in let nm_config, value_config = match nm with | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in var_redefine nm (fun () -> try let map = avlbl_config_get () in let value = SMap.find nm_config map in value_config value with Not_found -> failwithf (f_ "Cannot find field '%s' in '%s -config' output") nm (ocamlc ())) end module BaseStandardVar = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) open OASISGettext open OASISTypes open OASISExpr open BaseCheck open BaseEnv let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" let ocamlbuild = prog "ocamlbuild" (**/**) let rpkg = ref None let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") let var_cond = ref [] let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; fun () -> !holder () (**/**) let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) let c = BaseOCamlcConfig.var_define let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" (* TODO: Check standard variable presence at runtime *) let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" let bytecomp_c_compiler = c "bytecomp_c_compiler" let native_c_compiler = c "native_c_compiler" let model = c "model" let ext_obj = c "ext_obj" let ext_asm = c "ext_asm" let ext_lib = c "ext_lib" let ext_dll = c "ext_dll" let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" let flexlink = BaseCheck.prog "flexlink" let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) (**/**) let p name hlp dflt = var_define ~short_desc:hlp ~cli:CLIAuto ~arg_help:"dir" name dflt let (/) a b = if os_type () = Sys.os_type then Filename.concat a b else if os_type () = "Unix" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") (fun () -> match os_type () with | "Win32" -> let program_files = Sys.getenv "PROGRAMFILES" in program_files/(pkg_name ()) | _ -> "/usr/local") let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") (fun () -> raise (PropList.Not_set ("destdir", Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") let is_native = var_define "is_native" (fun () -> try let _s : string = ocamlopt () in "true" with PropList.Not_set _ -> let _s : string = ocamlc () in "false") let ext_program = var_define "suffix_program" (fun () -> match os_type () with | "Win32" -> ".exe" | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" (fun () -> match os_type () with | "Win32" -> "del" | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" (fun () -> match os_type () with | "Win32" -> "rd" | _ -> "rm -rf") let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") ~cli:CLIEnable "debug" (fun () -> "true") let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") ~cli:CLIEnable "profile" (fun () -> "false") let tests = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) "true" let docs = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true")) "true" let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.12.0")) in let flexdll_lt_030 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (flexdll_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false in if not has_native_dynlink then false else if ocaml_lt_312 () then false else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); false end else true in string_of_bool res) let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond end module BaseFileAB = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage let to_filename fn = let fn = OASISHostPath.of_unix fn in if not (Filename.check_suffix fn ".ab") then warning (f_ "File '%s' doesn't have '.ab' extension") fn; Filename.chop_extension fn let replace fn_lst = let buff = Buffer.create 13 in List.iter (fun fn -> let fn = OASISHostPath.of_unix fn in let chn_in = open_in fn in let chn_out = open_out (to_filename fn) in ( try while true do Buffer.add_string buff (var_expand (input_line chn_in)); Buffer.add_char buff '\n' done with End_of_file -> () ); Buffer.output_buffer chn_out buff; Buffer.clear buff; close_in chn_in; close_out chn_out) fn_lst end module BaseLog = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseLog.ml" *) open OASISUtils let default_filename = Filename.concat (Filename.dirname BaseEnv.default_filename) "setup.log" module SetTupleString = Set.Make (struct type t = string * string let compare (s11, s12) (s21, s22) = match String.compare s11 s21 with | 0 -> String.compare s12 s22 | n -> n end) let load () = if Sys.file_exists default_filename then begin let chn = open_in default_filename in let scbuf = Scanf.Scanning.from_file default_filename in let rec read_aux (st, lst) = if not (Scanf.Scanning.end_of_input scbuf) then begin let acc = try Scanf.bscanf scbuf "%S %S\n" (fun e d -> let t = e, d in if SetTupleString.mem t st then st, lst else SetTupleString.add t st, t :: lst) with Scanf.Scan_failure _ -> failwith (Scanf.bscanf scbuf "%l" (fun line -> Printf.sprintf "Malformed log file '%s' at line %d" default_filename line)) in read_aux acc end else begin close_in chn; List.rev lst end in read_aux (SetTupleString.empty, []) end else begin [] end let register event data = let chn_out = open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename in Printf.fprintf chn_out "%S %S\n" event data; close_out chn_out let unregister event data = if Sys.file_exists default_filename then begin let lst = load () in let chn_out = open_out default_filename in let write_something = ref false in List.iter (fun (e, d) -> if e <> event || d <> data then begin write_something := true; Printf.fprintf chn_out "%S %S\n" e d end) lst; close_out chn_out; if not !write_something then Sys.remove default_filename end let filter events = let st_events = List.fold_left (fun st e -> SetString.add e st) SetString.empty events in List.filter (fun (e, _) -> SetString.mem e st_events) (load ()) let exists event data = List.exists (fun v -> (event, data) = v) (load ()) end module BaseBuilt = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BDoc -> "doc")^ "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) let register t nm lst = BaseLog.register (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> if OASISFileUtil.file_exists_case fn then begin BaseLog.register (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn else fn); true end else registered) false alt in if not registered then warning (f_ "Cannot find an existing alternative files among: %s") (String.concat (s_ ", ") alt)) lst let unregister t nm = List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [to_log_event_file t nm; to_log_event_done t nm]) let fold t nm f acc = List.fold_left (fun acc (_, fn) -> if OASISFileUtil.file_exists_case fn then begin f acc fn end else begin warning (f_ "File '%s' has been marked as built \ for %s but doesn't exist") fn (Printf.sprintf (match t with | BExec | BExecLib -> (f_ "executable %s") | BLib -> (f_ "library %s") | BDoc -> (f_ "documentation %s")) nm); acc end) acc (BaseLog.filter [to_log_event_file t nm]) let is_built t nm = List.fold_left (fun is_built (_, d) -> (try bool_of_string d with _ -> false)) false (BaseLog.filter [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is (cs, bs, exec) (fun () -> bool_of_string (is_native ())) ext_dll ext_program in let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with | Some fn -> [BExecLib, cs.cs_name, [[ffn fn]]] | None -> []) in evs, unix_exec_is, unix_dll_opt let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) ~ext_dll:(ext_dll ()) (cs, bs, lib) in let evs = [BLib, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) (List.map var_expand (args @ (Array.to_list extra_args))) let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = function | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in match var_choose ~name:(s_ "Pre/Post Command") ~printer lst with | Some (cmd, args) -> begin try run cmd args [||] with e when failsafe -> warning (f_ "Command '%s' fail with error: %s") (String.concat " " (cmd :: args)) (match e with | Failure msg -> msg | e -> Printexc.to_string e) end | None -> () in let res = optional_command cstm.pre_command; f e in optional_command cstm.post_command; res end module BaseDynVar = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function | Executable (cs, bs, exec) -> if var_choose bs.bs_build then var_ignore (var_redefine (* We don't save this variable *) ~dump:false ~short_desc:(fun () -> Printf.sprintf (f_ "Filename of executable '%s'") cs.cs_name) (OASISUtils.varname_of_string cs.cs_name) (fun () -> let fn_opt = fold BExec cs.cs_name (fun _ fn -> Some fn) None in match fn_opt with | Some fn -> fn | None -> raise (PropList.Not_set (cs.cs_name, Some (Printf.sprintf (f_ "Executable '%s' not yet built.") cs.cs_name))))) | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISExpr open OASISGettext let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin let () = info (f_ "Running test '%s'") cs.cs_name in let back_cwd = match test.test_working_directory with | Some dir -> let cwd = Sys.getcwd () in let chdir d = info (f_ "Changing directory to '%s'") d; Sys.chdir d in chdir dir; fun () -> chdir cwd | None -> fun () -> () in try let failure_percent = BaseCustom.hook test.test_custom (test_plugin pkg (cs, test)) extra_args in back_cwd (); (failure_percent +. failure, n + 1) with e -> begin back_cwd (); raise e end end else begin info (f_ "Skipping test '%s'") cs.cs_name; (failure, n) end in let (failed, n) = List.fold_left one_test (0.0, 0) lst in let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in if failure_percent > 0.0 then failwith msg else info "%s" msg; (* Possible explanation why the tests where not run. *) if OASISVersion.version_0_3_or_after pkg.oasis_version && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose ~name:(Printf.sprintf (f_ "documentation %s build") cs.cs_name) ~printer:string_of_bool doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom (doc_plugin pkg (cs, doc)) extra_args end in List.iter one_doc lst; if OASISVersion.version_0_3_or_after pkg.oasis_version && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISSection open OASISGettext open OASISUtils type std_args_fun = package -> string array -> unit type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev (List.fold_left (fun acc sct -> match filter_map sct with | Some e -> e :: acc | None -> acc) [] lst) (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try List.assoc nm lst with Not_found -> failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom (fun () -> (* Reload if preconf has changed it *) begin try unload (); load (); with _ -> () end; (* Run plugin's configure *) t.configure t.package args; (* Dump to allow postconf to change it *) dump ()) (); (* Reload environment *) unload (); load (); (* Save environment *) print (); (* Replace data in file *) BaseFileAB.replace t.package.files_ab let build t args = BaseCustom.hook t.package.build_custom (t.build t.package) args let doc t args = BaseDoc.doc (join_plugin_sections (function | Doc (cs, e) -> Some (lookup_plugin_section "documentation" (s_ "build") cs.cs_name t.doc, cs, e) | _ -> None) t.package.sections) t.package args let test t args = BaseTest.test (join_plugin_sections (function | Test (cs, e) -> Some (lookup_plugin_section "test" (s_ "run") cs.cs_name t.test, cs, e) | _ -> None) t.package.sections) t.package args let all t args = let rno_doc = ref false in let rno_test = ref false in Arg.parse_argv ~current:(ref 0) (Array.of_list ((Sys.executable_name^" all") :: (Array.to_list args))) [ "-no-doc", Arg.Set rno_doc, s_ "Don't run doc target"; "-no-test", Arg.Set rno_test, s_ "Don't run test target"; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure t [||]; info "Running build step"; build t [||]; (* Load setup.log dynamic variables *) BaseDynVar.init t.package; if not !rno_doc then begin info "Running doc step"; doc t [||]; end else begin info "Skipping doc step" end; if not !rno_test then begin info "Running test step"; test t [||] end else begin info "Skipping test step" end let install t args = BaseCustom.hook t.package.install_custom (t.install t.package) args let uninstall t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall t.package) args let reinstall t args = uninstall t args; install t args let clean, distclean = let failsafe f a = try f a with e -> warning (f_ "Action fail with error: %s") (match e with | Failure msg -> msg | e -> Printexc.to_string e) in let generic_clean t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm (fun () -> (* Clean section *) List.iter (function | Test (cs, test) -> let f = try List.assoc cs.cs_name tests with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, test)) args | Doc (cs, doc) -> let f = try List.assoc cs.cs_name docs with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, doc)) args | Library _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter (fun f -> failsafe (f t.package) args) mains) () in let clean t args = generic_clean t t.package.clean_custom t.clean t.clean_doc t.clean_test args in let distclean t args = (* Call clean *) clean t args; (* Call distclean code *) generic_clean t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test args; (* Remove generated file *) List.iter (fun fn -> if Sys.file_exists fn then begin info (f_ "Remove '%s'") fn; Sys.remove fn end) (BaseEnv.default_filename :: BaseLog.default_filename :: (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in clean, distclean let version t _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> "_oasis" in let oasis_exec = match t.oasis_exec with | Some fn -> fn | None -> "oasis" in let ocaml = Sys.executable_name in let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> setup_ml, args | [] -> failwith (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. *) "ocaml", "setup.ml" else ocaml, setup_ml in let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in let do_update () = let oasis_exec_version = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | 1 -> failwithf (f_ "Executable '%s' is probably an old version \ of oasis (< 0.3.0), please update to version \ v%s.") oasis_exec t.oasis_version | 127 -> failwithf (f_ "Cannot find executable '%s', please install \ oasis v%s.") oasis_exec t.oasis_version | n -> failwithf (f_ "Command '%s version' exited with code %d.") oasis_exec n) oasis_exec ["version"] in if OASISVersion.comparator_apply (OASISVersion.version_of_string oasis_exec_version) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string t.oasis_version)) then begin (* We have a version >= for the executable oasis, proceed with * update. *) (* TODO: delegate this check to 'oasis setup'. *) if Sys.os_type = "Win32" then failwithf (f_ "It is not possible to update the running script \ setup.ml on Windows. Please update setup.ml by \ running '%s'.") (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) else begin OASISExec.run ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | n -> failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) end end else failwithf (f_ "The version of '%s' (v%s) doesn't match the version of \ oasis used to generate the %s file. Please install at \ least oasis v%s.") oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then begin try match t.oasis_digest with | Some dgst -> if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in try let act_ref = ref (fun _ -> failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) in let extra_args_ref = ref [] in let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = Arg.Tuple [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); Arg.Unit (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in Arg.parse (Arg.align ([ "-configure", arg_handle ~allow_empty_env:true configure, s_ "[options*] Configure the whole build process."; "-build", arg_handle build, s_ "[options*] Build executables and libraries."; "-doc", arg_handle doc, s_ "[options*] Build documents."; "-test", arg_handle test, s_ "[options*] Run tests."; "-all", arg_handle ~allow_empty_env:true all, s_ "[options*] Run configure, build, doc and test targets."; "-install", arg_handle install, s_ "[options*] Install libraries, data, executables \ and documents."; "-uninstall", arg_handle uninstall, s_ "[options*] Uninstall libraries, data, executables \ and documents."; "-reinstall", arg_handle reinstall, s_ "[options*] Uninstall and install libraries, data, \ executables and documents."; "-clean", arg_handle ~allow_empty_env:true clean, s_ "[options*] Clean files generated by a build."; "-distclean", arg_handle ~allow_empty_env:true distclean, s_ "[options*] Clean files generated by a build and configure."; "-version", arg_handle ~allow_empty_env:true version, s_ " Display version of OASIS used to generate this setup.ml."; "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; ] @ (if t.setup_update then [no_update_setup_ml_cli] else []) @ (BaseContext.args ()))) (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n"); (* Build initial environment *) load ~allow_empty:!allow_empty_env_ref (); (** Initialize flags *) List.iter (function | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) (fun () -> string_of_bool (var_choose ~name:(Printf.sprintf (f_ "default value of flag %s") cs.cs_name) ~printer:string_of_bool choices))) in match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end | _ -> ()) t.package.sections; BaseStandardVar.init t.package; BaseDynVar.init t.package; if t.setup_update && update_setup_ml t then () else !act_ref t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end # 4480 "setup.ml" module InternalConfigurePlugin = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall *) open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage (** Configure build using provided series of check to be done * and then output corresponding file. *) let configure pkg argv = let var_ignore_eval var = let _s : string = var () in () in let errors = ref SetString.empty in let buff = Buffer.create 13 in let add_errors fmt = Printf.kbprintf (fun b -> errors := SetString.add (Buffer.contents b) !errors; Buffer.clear b) buff fmt in let warn_exception e = warning "%s" (Printexc.to_string e) in (* Check tools *) let check_tools lst = List.iter (function | ExternalTool tool -> begin try var_ignore_eval (BaseCheck.prog tool) with e -> warn_exception e; add_errors (f_ "Cannot find external tool '%s'") tool end | InternalExecutable nm1 -> (* Check that matching tool is built *) List.iter (function | Executable ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal executable \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) lst in let build_checks sct bs = if var_choose bs.bs_build then begin if bs.bs_compiled_object = Native then begin try var_ignore_eval BaseStandardVar.ocamlopt with e -> warn_exception e; add_errors (f_ "Section %s requires native compilation") (OASISSection.string_of_section sct) end; (* Check tools *) check_tools bs.bs_build_tools; (* Check depends *) List.iter (function | FindlibPackage (findlib_pkg, version_comparator) -> begin try var_ignore_eval (BaseCheck.package ?version_comparator findlib_pkg) with e -> warn_exception e; match version_comparator with | None -> add_errors (f_ "Cannot find findlib package %s") findlib_pkg | Some ver_cmp -> add_errors (f_ "Cannot find findlib package %s (%s)") findlib_pkg (OASISVersion.string_of_comparator ver_cmp) end | InternalLibrary nm1 -> (* Check that matching library is built *) List.iter (function | Library ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal library \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) bs.bs_build_depends end in (* Parse command line *) BaseArgExt.parse argv (BaseEnv.args ()); (* OCaml version *) begin match pkg.ocaml_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "ocaml" ver_cmp BaseStandardVar.ocaml_version) with e -> warn_exception e; add_errors (f_ "OCaml version %s doesn't match version constraint %s") (BaseStandardVar.ocaml_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Findlib version *) begin match pkg.findlib_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "findlib" ver_cmp BaseStandardVar.findlib_version) with e -> warn_exception e; add_errors (f_ "Findlib version %s doesn't match version constraint %s") (BaseStandardVar.findlib_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || BaseStandardVar.os_type () = "Cygwin" then begin try var_ignore_eval BaseStandardVar.flexlink with e -> warn_exception e; add_errors (f_ "Cannot find 'flexlink'") end; (* Check build depends *) List.iter (function | Executable (_, bs, _) | Library (_, bs, _) as sct -> build_checks sct bs | Doc (_, doc) -> if var_choose doc.doc_build then check_tools doc.doc_build_tools | Test (_, test) -> if var_choose test.test_run then check_tools test.test_tools | _ -> ()) pkg.sections; (* Check if we need native dynlink (presence of libraries that compile to * native) *) begin let has_cmxa = List.exists (function | Library (_, bs, _) -> var_choose bs.bs_build && (bs.bs_compiled_object = Native || (bs.bs_compiled_object = Best && bool_of_string (BaseStandardVar.is_native ()))) | _ -> false) pkg.sections in if has_cmxa then var_ignore_eval BaseStandardVar.native_dynlink end; (* Check errors *) if SetString.empty != !errors then begin List.iter (fun e -> error "%s" e) (SetString.elements !errors); failwithf (fn_ "%d configuration error" "%d configuration errors" (SetString.cardinal !errors)) (SetString.cardinal !errors) end end module InternalInstallPlugin = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall *) open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes open OASISLibrary open OASISGettext open OASISUtils let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) let doc_hook = ref (fun (cs, doc) -> cs, doc) let install_file_ev = "install-file" let install_dir_ev = "install-dir" let install_findlib_ev = "install-findlib" let win32_max_command_line_length = 8000 let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) let first_args = ["install"; findlib_name; meta] in (* Arguments for remaining commands: *) let other_args = ["install"; findlib_name; "-add"] in (* Extract as much files as possible from [files], [len] is the current command line length: *) let rec get_files len acc files = match files with | [] -> (List.rev acc, []) | file :: rest -> let len = len + 1 + String.length file in if len > win32_max_command_line_length then (List.rev acc, files) else get_files len (file :: acc) rest in (* Split the command into several commands. *) let rec split args files = match files with | [] -> [] | _ -> (* Length of "ocamlfind install [META|-add]" *) let len = List.fold_left (fun len arg -> len + 1 (* for the space *) + String.length arg) (String.length ocamlfind) args in match get_files len [] files with | ([], _) -> failwith (s_ "Command line too long.") | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) let () = let findlib_ge_132 = OASISVersion.comparator_apply (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf (f_ "Installing the library %s require to use the flag \ '-add' of ocamlfind because the command line is too \ long. This flag is only available for findlib 1.3.2. \ Please upgrade findlib from %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in cmd :: cmds in (* The first command does not use -add: *) split first_args files else ["install" :: findlib_name :: meta :: files] let install pkg argv = let in_destdir = try let destdir = destdir () in (* Practically speaking destdir is prepended * at the beginning of the target filename *) fun fn -> destdir^fn with PropList.Not_set _ -> fun fn -> fn in let install_file ?tgt_fn src_file envdir = let tgt_dir = in_destdir (envdir ()) in let tgt_file = Filename.concat tgt_dir (match tgt_fn with | Some fn -> fn | None -> Filename.basename src_file) in (* Create target directory if needed *) OASISFileUtil.mkdir_parent ~ctxt:!BaseContext.default (fun dn -> info (f_ "Creating directory '%s'") dn; BaseLog.register install_dir_ev dn) tgt_dir; (* Really install files *) info (f_ "Copying file '%s' to '%s'") src_file tgt_file; OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; BaseLog.register install_file_ev tgt_file in (* Install data into defined directory *) let install_data srcdir lst tgtdir = let tgtdir = OASISHostPath.of_unix (var_expand tgtdir) in List.iter (fun (src, tgt_opt) -> let real_srcs = OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat srcdir src) in if real_srcs = [] then failwithf (f_ "Wildcard '%s' doesn't match any files") src; List.iter (fun fn -> install_file fn (fun () -> match tgt_opt with | Some s -> OASISHostPath.of_unix (var_expand s) | None -> tgtdir)) real_srcs) lst in (** Install all libraries *) let install_libs pkg = let files_of_library (f_data, acc) data_lib = let cs, bs, lib, lib_extra = !lib_hook data_lib in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then begin let acc = (* Start with acc + lib_extra *) List.rev_append lib_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left (fun acc modul -> try List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) [modul^".mli"; modul^".ml"; String.uncapitalize modul^".mli"; String.capitalize modul^".mli"; String.uncapitalize modul^".ml"; String.capitalize modul^".ml"]) :: acc with Not_found -> begin warning (f_ "Cannot find source header for module %s \ in library %s") modul cs.cs_name; acc end) acc lib.lib_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BLib cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the library *) install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end in (* Install one group of library *) let install_group_lib grp = (* Iterate through all group nodes *) let rec install_group_lib_aux data_and_files grp = let data_and_files, children = match grp with | Container (_, children) -> data_and_files, children | Package (_, cs, bs, lib, children) -> files_of_library data_and_files (cs, bs, lib), children in List.fold_left install_group_lib_aux data_and_files children in (* Findlib name of the root library *) let findlib_name = findlib_of_group grp in (* Determine root library *) let root_lib = root_of_group grp in (* All files to install for this library *) let f_data, files = install_group_lib_aux (ignore, []) grp in (* Really install, if there is something to install *) if files = [] then begin warning (f_ "Nothing to install for findlib library '%s'") findlib_name end else begin let meta = (* Search META file *) let (_, bs, _) = root_lib in let res = Filename.concat bs.bs_path "META" in if not (OASISFileUtil.file_exists_case res) then failwithf (f_ "Cannot find file '%s' for findlib library %s") res findlib_name; res in let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) let remove_prefix p n = let plen = String.length p in let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) in String.sub n cutpoint (nlen - cutpoint) end else n in List.map (remove_prefix (Sys.getcwd ())) files in info (f_ "Installing findlib library '%s'") findlib_name; let ocamlfind = ocamlfind () in let commands = split_install_command ocamlfind findlib_name meta files in List.iter (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) commands; BaseLog.register install_findlib_ev findlib_name end; (* Install data files *) f_data (); in let group_libs, _, _ = findlib_mapping pkg in (* We install libraries in groups *) List.iter install_group_lib group_libs in let install_execs pkg = let install_exec data_exec = let (cs, bs, exec) = !exec_hook data_exec in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then begin let exec_libdir () = Filename.concat (libdir ()) pkg.name in BaseBuilt.fold BaseBuilt.BExec cs.cs_name (fun () fn -> install_file ~tgt_fn:(cs.cs_name ^ ext_program ()) fn bindir) (); BaseBuilt.fold BaseBuilt.BExecLib cs.cs_name (fun () fn -> install_file fn exec_libdir) (); install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name) end in List.iter (function | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) | _ -> ()) pkg.sections in let install_docs pkg = let install_doc data = let (cs, doc) = !doc_hook data in if var_choose doc.doc_install && BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then begin let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in BaseBuilt.fold BaseBuilt.BDoc cs.cs_name (fun () fn -> install_file fn (fun () -> tgt_dir)) (); install_data Filename.current_dir_name doc.doc_data_files doc.doc_install_dir end in List.iter (function | Doc (cs, doc) -> install_doc (cs, doc) | _ -> ()) pkg.sections in install_libs pkg; install_execs pkg; install_docs pkg (* Uninstall already installed data *) let uninstall _ argv = List.iter (fun (ev, data) -> if ev = install_file_ev then begin if OASISFileUtil.file_exists_case data then begin info (f_ "Removing file '%s'") data; Sys.remove data end else begin warning (f_ "File '%s' doesn't exist anymore") data end end else if ev = install_dir_ev then begin if Sys.file_exists data && Sys.is_directory data then begin if Sys.readdir data = [||] then begin info (f_ "Removing directory '%s'") data; OASISFileUtil.rmdir ~ctxt:!BaseContext.default data end else begin warning (f_ "Directory '%s' is not empty (%s)") data (String.concat ", " (Array.to_list (Sys.readdir data))) end end else begin warning (f_ "Directory '%s' doesn't exist anymore") data end end else if ev = install_findlib_ev then begin info (f_ "Removing findlib library '%s'") data; OASISExec.run ~ctxt:!BaseContext.default (ocamlfind ()) ["remove"; data] end else failwithf (f_ "Unknown log event '%s'") ev; BaseLog.unregister ev data) (* We process event in reverse order *) (List.rev (BaseLog.filter [install_file_ev; install_dir_ev; install_findlib_ev;])) end # 5233 "setup.ml" module OCamlbuildCommon = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) open OASISGettext open BaseEnv open BaseStandardVar let ocamlbuild_clean_ev = "ocamlbuild-clean" let ocamlbuildflags = var_define ~short_desc:(fun () -> "OCamlbuild additional flags") "ocamlbuildflags" (fun () -> "") (** Fix special arguments depending on environment *) let fix_args args extra_argv = List.flatten [ if (os_type ()) = "Win32" then [ "-classic-display"; "-no-log"; "-no-links"; "-install-lib-dir"; (Filename.concat (standard_library ()) "ocamlbuild") ] else []; if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then [ "-byte-plugin" ] else []; args; if bool_of_string (debug ()) then ["-tag"; "debug"] else []; if bool_of_string (profile ()) then ["-tag"; "profile"] else []; OASISString.nsplit (ocamlbuildflags ()) ' '; Array.to_list extra_argv; ] (** Run 'ocamlbuild -clean' if not already done *) let run_clean extra_argv = let extra_cli = String.concat " " (Array.to_list extra_argv) in (* Run if never called with these args *) if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then begin OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args ["-clean"] extra_argv); BaseLog.register ocamlbuild_clean_ev extra_cli; at_exit (fun () -> try BaseLog.unregister ocamlbuild_clean_ev extra_cli with _ -> ()) end (** Run ocamlbuild, unregister all clean events *) let run_ocamlbuild args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html *) OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args args extra_argv); (* Remove any clean event, we must run it again *) List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [ocamlbuild_clean_ev]) (** Determine real build directory *) let build_dir extra_argv = let rec search_args dir = function | "-build-dir" :: dir :: tl -> search_args dir tl | _ :: tl -> search_args dir tl | [] -> dir in search_args "_build" (fix_args [] extra_argv) end module OCamlbuildPlugin = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISUtils open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage let cond_targets_hook = ref (fun lst -> lst) let build pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat (build_dir argv) fn in (* Return the unix filename in host build directory *) let in_build_dir_of_unix fn = in_build_dir (OASISHostPath.of_unix fn) in let cond_targets = List.fold_left (fun acc -> function | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_library in_build_dir_of_unix (cs, bs, lib) in let ends_with nd fn = let nd_len = String.length nd in (String.length fn >= nd_len) && (String.sub fn (String.length fn - nd_len) nd_len) = nd in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ".cma" fn || ends_with ".cmxs" fn || ends_with ".cmxa" fn || ends_with (ext_lib ()) fn || ends_with (ext_dll ()) fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for library %s") cs.cs_name end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, unix_exec_is, unix_dll_opt = BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) in let target ext = let unix_tgt = (OASISUnixPath.concat bs.bs_path (OASISUnixPath.chop_extension exec.exec_main_is))^ext in let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs in evs, [unix_tgt] in (* Add executable *) let acc = match bs.bs_compiled_object with | Native -> (target ".native") :: acc | Best when bool_of_string (is_native ()) -> (target ".native") :: acc | Byte | Best -> (target ".byte") :: acc in acc end | Library _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] (* Keep the pkg.sections ordered *) (List.rev pkg.sections); in (* Check and register built files *) let check_and_register (bt, bnm, lst) = List.iter (fun fns -> if not (List.exists OASISFileUtil.file_exists_case fns) then failwithf (f_ "No one of expected built files %s exists") (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in let cond_targets = (* Run the hook *) !cond_targets_hook cond_targets in (* Run a list of target... *) run_ocamlbuild (List.flatten (List.map snd cond_targets)) argv; (* ... and register events *) List.iter check_and_register (List.flatten (List.map fst cond_targets)) let clean pkg extra_args = run_clean extra_args; List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections end module OCamlbuildDocPlugin = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISMessage open OCamlbuildCommon open BaseStandardVar let doc_build path pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ path; cs.cs_name^".docdir"; "index.html"; ] in let tgt_dir = OASISHostPath.make [ build_dir argv; OASISHostPath.of_unix path; cs.cs_name^".docdir"; ] in run_ocamlbuild [index_html] argv; List.iter (fun glb -> BaseBuilt.register BaseBuilt.BDoc cs.cs_name [OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat tgt_dir glb)]) ["*.html"; "*.css"] let doc_clean t pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name end # 5558 "setup.ml" module CustomPlugin = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/custom/CustomPlugin.ml" *) (** Generate custom configure/build/doc/test/install system @author *) open BaseEnv open OASISGettext open OASISTypes type t = { cmd_main: command_line conditional; cmd_clean: (command_line option) conditional; cmd_distclean: (command_line option) conditional; } let run = BaseCustom.run let main t _ extra_args = let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in run cmd args extra_args let clean t pkg extra_args = match var_choose t.cmd_clean with | Some (cmd, args) -> run cmd args extra_args | _ -> () let distclean t pkg extra_args = match var_choose t.cmd_distclean with | Some (cmd, args) -> run cmd args extra_args | _ -> () module Build = struct let main t pkg extra_args = main t pkg extra_args; List.iter (fun sct -> let evs = match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, _ = BaseBuilt.of_library OASISHostPath.of_unix (cs, bs, lib) in evs end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, _, _ = BaseBuilt.of_executable OASISHostPath.of_unix (cs, bs, exec) in evs end | _ -> [] in List.iter (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) evs) pkg.sections let clean t pkg extra_args = clean t pkg extra_args; (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild * considering moving this to BaseSetup? *) List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections let distclean t pkg extra_args = distclean t pkg extra_args end module Test = struct let main t pkg (cs, test) extra_args = try main t pkg extra_args; 0.0 with Failure s -> BaseMessage.warning (f_ "Test '%s' fails: %s") cs.cs_name s; 1.0 let clean t pkg (cs, test) extra_args = clean t pkg extra_args let distclean t pkg (cs, test) extra_args = distclean t pkg extra_args end module Doc = struct let main t pkg (cs, _) extra_args = main t pkg extra_args; BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] let clean t pkg (cs, _) extra_args = clean t pkg extra_args; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name let distclean t pkg (cs, _) extra_args = distclean t pkg extra_args end end # 5694 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build; test = [ ("test_runner", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_runner", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }); ("mac_test", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$mac_test", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }) ]; doc = [("bin_prot", OCamlbuildDocPlugin.doc_build "lib")]; install = InternalInstallPlugin.install; uninstall = InternalInstallPlugin.uninstall; clean = [OCamlbuildPlugin.clean]; clean_test = [ ("test_runner", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_runner", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }); ("mac_test", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$mac_test", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }) ]; clean_doc = [("bin_prot", OCamlbuildDocPlugin.doc_clean "lib")]; distclean = []; distclean_test = [ ("test_runner", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_runner", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }); ("mac_test", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$mac_test", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }) ]; distclean_doc = []; package = { oasis_version = "0.3"; ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.0"); findlib_version = Some (OASISVersion.VGreaterEqual "1.3.2"); name = "bin_prot"; version = "109.30.00"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit { OASISLicense.license = "Apache"; excption = None; version = OASISLicense.Version "2.0"; }); license_file = Some "LICENSE.txt"; copyrights = [ "(C) 2008-2013 Jane Street Capital LLC " ]; maintainers = ["Jane Street Capital LLC "]; authors = ["Jane Street Capital LLC "]; homepage = Some "https://github.com/janestreet/bin_prot"; synopsis = "bin_prot - binary protocol generator"; description = None; categories = []; conf_type = (`Configure, "internal", Some "0.3"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [ (OASISExpr.EBool true, Some (("config/arch.sh", ["$ocamlc"]))) ]; }; build_type = (`Build, "ocamlbuild", Some "0.3"); build_custom = { pre_command = [ (OASISExpr.EBool true, Some (("mkdir", [ "-p"; "_build;"; "cp"; "lib/*.mlh"; "lib/*.h"; "_build/" ]))) ]; post_command = [(OASISExpr.EBool true, None)]; }; install_type = (`Install, "internal", Some "0.3"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; files_ab = []; sections = [ Library ({ cs_name = "bin_prot"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "lib"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("unix", None); FindlibPackage ("bigarray", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = [ "common_stubs.c"; "common_stubs.h"; "int64_native.h"; "int64_emul.h"; "write_stubs.c"; "read_stubs.c" ]; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { lib_modules = [ "Binable"; "Nat0"; "Common"; "Unsafe_common"; "Unsafe_write_c"; "Unsafe_read_c"; "Size"; "Write_ml"; "Read_ml"; "Write_c"; "Read_c"; "Std"; "Type_class"; "Map_to_safe"; "Utils" ]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = []; }); Library ({ cs_name = "pa_bin_prot"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "syntax"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("camlp4.quotations", None); FindlibPackage ("camlp4.extend", None); FindlibPackage ("type_conv", Some (OASISVersion.VGreaterEqual "3.0.5")) ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { lib_modules = ["Pa_bin_prot"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "bin_prot"; lib_findlib_name = Some "syntax"; lib_findlib_containers = []; }); Executable ({ cs_name = "test_runner"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "tests", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "lib_test"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "bin_prot"; InternalLibrary "pa_bin_prot"; FindlibPackage ("oUnit", Some (OASISVersion.VGreaterEqual "1.0.2")) ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, {exec_custom = true; exec_main_is = "test_runner.ml"; }); Test ({ cs_name = "test_runner"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { test_type = (`Test, "custom", Some "0.3"); test_command = [(OASISExpr.EBool true, ("$test_runner", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; test_working_directory = Some "lib_test"; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EFlag "tests"), true) ]; test_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; }); Executable ({ cs_name = "mac_test"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "tests", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "lib_test"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "bin_prot"; InternalLibrary "pa_bin_prot" ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, {exec_custom = true; exec_main_is = "mac_test.ml"; }); Test ({ cs_name = "mac_test"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { test_type = (`Test, "custom", Some "0.3"); test_command = [(OASISExpr.EBool true, ("$mac_test", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; test_working_directory = Some "lib_test"; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EFlag "tests"), true) ]; test_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; }); Executable ({ cs_name = "example"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "tests", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "lib_test"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "bin_prot"; InternalLibrary "pa_bin_prot" ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, {exec_custom = false; exec_main_is = "example.ml"; }); Doc ({ cs_name = "bin_prot"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { doc_type = (`Doc, "ocamlbuild", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); (OASISExpr.EFlag "docs", true) ]; doc_install = [(OASISExpr.EBool true, true)]; doc_install_dir = "$docdir"; doc_title = "API reference for bin_prot"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = []; doc_build_tools = [ ExternalTool "ocamlbuild"; ExternalTool "camlp4o"; ExternalTool "ocamldoc" ]; }) ]; plugins = [ (`Extra, "StdFiles", Some "0.3"); (`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3") ]; schema_data = PropList.Data.create (); plugin_data = []; }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; oasis_digest = Some "\021\143#\243\249\156\235}MU8\161\253:\208&"; oasis_exec = None; oasis_setup_args = []; setup_update = false; };; let setup () = BaseSetup.setup setup_t;; # 6151 "setup.ml" (* OASIS_STOP *) let () = setup () bin_prot-109.30.00/syntax/000077500000000000000000000000001216015522300151635ustar00rootroot00000000000000bin_prot-109.30.00/syntax/pa_bin_prot.ml000066400000000000000000001447411216015522300200240ustar00rootroot00000000000000(** Pa_bin_prot: Preprocessing Module for a Type Safe Binary Protocol *) open Printf open Camlp4 open PreCast open Ast open Pa_type_conv (* Utility functions *) let ( *** ) f g x = f (g x) let rec sig_of_tds cnv = function | TyDcl (_loc, type_name, tps, _rhs, _cl) -> cnv _loc type_name tps | TyAnd (_loc, tp1, tp2) -> <:sig_item< $sig_of_tds cnv tp1$; $sig_of_tds cnv tp2$ >> | _ -> assert false (* impossible *) let mk_full_type loc type_name tps = let coll_args tp param = <:ctyp@loc< $tp$ $Gen.drop_variance_annotations param$ >> in List.fold_left coll_args <:ctyp@loc< $lid:type_name$ >> tps (* Generators for the binary protocol *) (* Generates the signature for binary protocol writers *) module Sig_generate_writer = struct let sig_of_td _loc type_name tps = let rec loop this_type = function | [] -> <:ctyp< Bin_prot.Write_ml.writer $this_type$ >>, <:ctyp< Bin_prot.Unsafe_write_c.writer $this_type$ >>, <:ctyp< Bin_prot.Size.sizer $this_type$ >>, <:ctyp< Bin_prot.Type_class.writer $this_type$ >> | tp :: tps -> let tp = Gen.drop_variance_annotations tp in let bin_write, bin_write_low, bin_size, bin_writer = loop <:ctyp< $this_type$ $tp$ >> tps in <:ctyp< Bin_prot.Unsafe_write_c.writer $tp$ -> $bin_write$ >>, <:ctyp< Bin_prot.Unsafe_write_c.writer $tp$ -> $bin_write_low$ >>, <:ctyp< Bin_prot.Size.sizer $tp$ -> $bin_size$ >>, <:ctyp< Bin_prot.Type_class.writer $tp$ -> $bin_writer$ >> in let bin_write, bin_write_low, bin_size, bin_writer = loop <:ctyp< $lid:type_name$ >> tps in <:sig_item< value $lid:"bin_size_" ^ type_name$ : $bin_size$; value $lid:"bin_write_" ^ type_name$ : $bin_write$; value $lid:"bin_write_" ^ type_name ^ "_"$ : $bin_write_low$; value $lid:"bin_writer_" ^ type_name$ : $bin_writer$ >> let mk_sig _rec tds = <:sig_item< $sig_of_tds sig_of_td tds$ >> let () = add_sig_generator ~delayed:true "bin_write" mk_sig; end (* Generates the signature for binary protocol readers *) module Sig_generate_reader = struct let sig_of_td _loc type_name tps = let rec loop this_tp = function | [] -> <:ctyp< Bin_prot.Read_ml.reader $this_tp$ >>, <:ctyp< Bin_prot.Unsafe_read_c.reader $this_tp$ >>, <:ctyp< Bin_prot.Unsafe_read_c.reader (int -> $this_tp$) >>, <:ctyp< Bin_prot.Type_class.reader $this_tp$ >> | tp :: tps -> let tp = Gen.drop_variance_annotations tp in let bin_read, bin_read_, bin_read__, bin_reader = loop <:ctyp< $this_tp$ $tp$ >> tps in <:ctyp< Bin_prot.Unsafe_read_c.reader $tp$ -> $bin_read$ >>, <:ctyp< Bin_prot.Unsafe_read_c.reader $tp$ -> $bin_read_$ >>, <:ctyp< Bin_prot.Unsafe_read_c.reader $tp$ -> $bin_read__$ >>, <:ctyp< Bin_prot.Type_class.reader $tp$ -> $bin_reader$ >> in let bin_read, bin_read_, bin_read__, bin_reader = loop <:ctyp< $lid:type_name$ >> tps in <:sig_item< value $lid:"bin_read_" ^ type_name$ : $bin_read$; value $lid:"bin_read_" ^ type_name ^ "_"$ : $bin_read_$; value $lid:"bin_read_" ^ type_name ^ "__"$ : $bin_read__$; value $lid:"bin_reader_" ^ type_name$ : $bin_reader$ >> let mk_sig _rec tds = <:sig_item< $sig_of_tds sig_of_td tds$ >> let () = add_sig_generator ~delayed:true "bin_read" mk_sig; end (* Generates the signature for binary protocol type classes *) module Sig_generate_tp_class = struct let sig_of_td _loc type_name tps = let rec loop this_tp = function | [] -> <:ctyp< Bin_prot.Type_class.t $this_tp$ >> | tp :: tps -> let tp = Gen.drop_variance_annotations tp in let bin_tp_class = loop <:ctyp< $this_tp$ $tp$ >> tps in <:ctyp< Bin_prot.Type_class.t $tp$ -> $bin_tp_class$ >> in let bin_tp_class = loop <:ctyp< $lid:type_name$ >> tps in <:sig_item< value $lid:"bin_" ^ type_name$ : $bin_tp_class$ >> let mk_sig _rec tds = <:sig_item< $sig_of_tds sig_of_td tds$ >> let () = add_sig_generator ~delayed:true "bin_type_class" mk_sig end (* Generates the signature for binary protocol *) module Sig_generate = struct let () = add_sig_set "bin_io" ~set:["bin_write"; "bin_read"; "bin_type_class"]; end (* Generator for size computation of OCaml-values for the binary protocol *) module Generate_bin_size = struct let mk_abst_call _loc tn rev_path = <:expr< $id:Gen.ident_of_rev_path _loc (("bin_size_" ^ tn) :: rev_path)$ >> (* Conversion of type paths *) let bin_size_path_fun _loc id = match Gen.get_rev_id_path id [] with | tn :: rev_path -> mk_abst_call _loc tn rev_path | [] -> assert false (* impossible *) (* Conversion of types *) let rec bin_size_type full_type_name _loc = function | <:ctyp< $tp1$ $tp2$ >> -> `Fun (bin_size_appl_fun full_type_name _loc tp1 tp2) | <:ctyp< ( $tup:tp$ ) >> -> bin_size_tuple full_type_name _loc tp | <:ctyp< '$parm$ >> -> `Fun <:expr< $lid:"_size_of_" ^ parm$ >> | <:ctyp< $id:id$ >> -> `Fun (bin_size_path_fun _loc id) | <:ctyp< $_$ -> $_$ >> -> failwith "bin_size_type: cannot convert functions to the binary protocol" | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> | <:ctyp< [= $row_fields$ ] >> -> bin_size_variant full_type_name _loc row_fields | <:ctyp< ! $parms$ . $tp$ >> -> bin_size_poly full_type_name _loc parms tp | _ -> prerr_endline ( get_loc_err _loc "bin_size_type: unknown type construct"); exit 1 (* Conversion of polymorphic types *) and bin_size_appl_fun full_type_name _loc tp1 tp2 = match bin_size_type full_type_name _loc tp1, bin_size_type full_type_name _loc tp2 with | `Fun <:expr< Bin_prot.Size.bin_size_array >>, `Fun <:expr< Bin_prot.Size.bin_size_float >> -> <:expr< Bin_prot.Size.bin_size_float_array >> | `Fun fun_expr1, `Fun fun_expr2 -> <:expr< $fun_expr1$ $fun_expr2$ >> | `Fun fun_expr, `Match matching -> <:expr< $fun_expr$ (fun [ $matching$ ]) >> | _ -> assert false (* impossible *) (* Conversion of tuples and records *) and bin_size_args full_type_name _loc get_tp mk_patt tp = let rec loop i = function | el :: rest -> let tp = get_tp el in let v_name = "v" ^ string_of_int i in let v_expr = match bin_size_type full_type_name _loc tp with | `Fun fun_expr -> <:expr< Pervasives.(+) size ($fun_expr$ $lid:v_name$) >> | `Match matchings -> <:expr< Pervasives.(+) size (match $lid:v_name$ with [ $matchings$ ]) >> in let patt = mk_patt _loc v_name el in if rest = [] then [patt], v_expr else let patts, in_expr = loop (i + 1) rest in patt :: patts, <:expr< let size = $v_expr$ in $in_expr$ >> | [] -> assert false (* impossible *) in loop 1 (list_of_ctyp tp []) and bin_size_tup_rec full_type_name _loc cnv_patts get_tp mk_patt tp = let patts, expr = bin_size_args full_type_name _loc get_tp mk_patt tp in `Match <:match_case< $cnv_patts patts$ -> let size = 0 in $expr$ >> (* Conversion of tuples *) and bin_size_tuple full_type_name _loc tp = let cnv_patts patts = <:patt< ( $tup:paCom_of_list patts$ ) >> in let get_tp tp = tp in let mk_patt _loc v_name _ = <:patt< $lid:v_name$ >> in bin_size_tup_rec full_type_name _loc cnv_patts get_tp mk_patt tp (* Conversion of records *) and bin_size_record full_type_name _loc tp = let cnv_patts patts = <:patt< { $paSem_of_list patts$ } >> in let get_tp = function | <:ctyp< $_$ : mutable $tp$ >> | <:ctyp< $_$ : $tp$ >> -> tp | _ -> assert false (* impossible *) in let mk_patt _loc v_name = function | <:ctyp< $lid:r_name$ : $_$ >> -> <:patt< $lid:r_name$ = $lid:v_name$ >> | _ -> assert false (* impossible *) in bin_size_tup_rec full_type_name _loc cnv_patts get_tp mk_patt tp (* Conversion of variant types *) and bin_size_variant full_type_name _loc row_fields = let has_atoms = ref false in let rec loop = function | <:ctyp< $tp1$ | $tp2$ >> -> <:match_case< $loop tp1$ | $loop tp2$ >> | <:ctyp< `$_$ >> -> has_atoms := true; <:match_case< >> | <:ctyp< `$cnstr$ of $tp$ >> -> let size_args = match bin_size_type full_type_name _loc tp with | `Fun fun_expr -> <:expr< $fun_expr$ args >> | `Match matchings -> <:expr< match args with [ $matchings$ ] >> in <:match_case< `$cnstr$ args -> let size_args = $size_args$ in Pervasives.(+) size_args 4 >> | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> | <:ctyp< [= $row_fields$ ] >> -> loop row_fields | <:ctyp< $tp1$ $tp2$ >> -> let id_path = Gen.get_appl_path _loc tp1 in let call = bin_size_appl_fun full_type_name _loc tp1 tp2 in <:match_case< #$id_path$ as v -> $call$ v >> | <:ctyp< $id:id$ >> | <:ctyp< #$id:id$ >> -> let call = match Gen.get_rev_id_path id [] with | tn :: path -> mk_abst_call _loc tn path | [] -> assert false (* impossible *) in <:match_case< #$id$ as v -> $call$ v >> | _ -> failwith "bin_size_variant: unknown type" in let nonatom_matchings = loop row_fields in let matchings = if !has_atoms then <:match_case< $nonatom_matchings$ | _ -> 4 >> else nonatom_matchings in `Match matchings (* Polymorphic record fields *) and bin_size_poly full_type_name _loc parms tp = let bindings = let mk_binding parm = <:binding< $lid:"_size_of_" ^ parm$ = fun _v -> raise (Bin_prot.Common.Poly_rec_write $str:full_type_name$) >> in List.map mk_binding (Gen.ty_var_list_of_ctyp parms []) in match bin_size_type full_type_name _loc tp with | `Fun fun_expr -> `Fun <:expr< let $list:bindings$ in $fun_expr$ >> | `Match matchings -> `Match <:match_case< arg -> let $list:bindings$ in match arg with [ $matchings$ ] >> (* Conversion of sum types *) let rec count_alts = function | <:ctyp< $tp1$ | $tp2$ >> -> count_alts tp1 + count_alts tp2 | _ -> 1 let bin_size_sum full_type_name _loc alts = let n_alts = count_alts alts in let size_tag = if n_alts <= 256 then <:expr< 1 >> else if n_alts <= 65536 then <:expr< 2 >> else ( prerr_endline ( get_loc_err _loc "bin_size_sum: too many alternatives (> 65536)"); exit 1) in let has_atoms = ref false in let rec loop = function | <:ctyp< $tp1$ | $tp2$ >> -> <:match_case< $loop tp1$ | $loop tp2$ >> | <:ctyp< $uid:_$ >> -> has_atoms := true; <:match_case< >> | <:ctyp< $uid:cnstr$ of $tp$ >> -> let get_tp tp = tp in let mk_patt _loc v_name _ = <:patt< $lid:v_name$ >> in let patts, size_args = bin_size_args full_type_name _loc get_tp mk_patt tp in let args = match patts with | [patt] -> patt | _ -> <:patt< $tup:paCom_of_list patts$ >> in <:match_case< $uid:cnstr$ $args$ -> let size = $size_tag$ in $size_args$ >> | <:ctyp< $_$ : $_$ >> as tp -> Gen.error tp ~fn:"bin_size_sum" ~msg:"GADTs are not supported by bin_prot" | tp -> Gen.unknown_type tp "bin_size_sum" in let nonatom_matchings = loop alts in let matchings = if !has_atoms then <:match_case< $nonatom_matchings$ | _ -> $size_tag$ >> else nonatom_matchings in `Match matchings (* Empty types *) let bin_size_nil full_type_name _loc = `Fun <:expr< fun _v -> raise (Bin_prot.Common.Empty_type $str:full_type_name$) >> (* Generate code from type definitions *) let bin_size_td _loc type_name tps rhs = let full_type_name = sprintf "%s.%s" (get_conv_path ()) type_name in let is_nil = ref false in let body = let rec loop _loc = Gen.switch_tp_def ~alias:(bin_size_type full_type_name) ~sum:(bin_size_sum full_type_name) ~record:(bin_size_record full_type_name) ~variants:(bin_size_variant full_type_name) ~mani:(fun _loc _tp1 -> loop _loc) ~nil:(fun _loc -> is_nil := true; bin_size_nil full_type_name _loc) in match loop _loc rhs with | `Fun fun_expr when !is_nil -> fun_expr | `Fun fun_expr -> <:expr< fun v -> $fun_expr$ v >> | `Match matchings -> <:expr< fun [ $matchings$ ] >> in let tparam_cnvs = List.map ((^) "_size_of_" *** Gen.get_tparam_id) tps in let mk_pat id = <:patt< $lid:id$ >> in let tparam_patts = List.map mk_pat tparam_cnvs in <:binding< $lid:"bin_size_" ^ type_name$ = $Gen.abstract _loc tparam_patts body$ >> let rec bin_size_tds acc = function | TyDcl (_loc, type_name, tps, rhs, _cl) -> bin_size_td _loc type_name tps rhs :: acc | TyAnd (_loc, tp1, tp2) -> bin_size_tds (bin_size_tds acc tp2) tp1 | _ -> assert false (* impossible *) let bin_size rec_ tds = let bindings, recursive, _loc = match tds with | TyDcl (_loc, type_name, tps, rhs, _cl) -> let binding = bin_size_td _loc type_name tps rhs in [binding], rec_ && Gen.type_is_recursive type_name rhs, _loc | TyAnd (_loc, _, _) -> bin_size_tds [] tds, rec_, _loc | _ -> assert false (* impossible *) in if recursive then <:str_item< value rec $list:bindings$ >> else <:str_item< value $list:bindings$ >> end (* Generator for converters of OCaml-values to the binary protocol *) module Generate_bin_write = struct let mk_abst_call _loc tn rev_path = <:expr< $id:Gen.ident_of_rev_path _loc (("bin_write_" ^ tn ^ "_") :: rev_path)$ >> (* Conversion of type paths *) let bin_write_path_fun _loc id = match Gen.get_rev_id_path id [] with | tn :: rev_path -> mk_abst_call _loc tn rev_path | [] -> assert false (* impossible *) (* Conversion of types *) let rec bin_write_type full_type_name _loc = function | <:ctyp< $tp1$ $tp2$ >> -> `Fun (bin_write_appl_fun full_type_name _loc tp1 tp2) | <:ctyp< ( $tup:tp$ ) >> -> bin_write_tuple full_type_name _loc tp | <:ctyp< '$parm$ >> -> `Fun <:expr< $lid:"_write_" ^ parm$ >> | <:ctyp< $id:id$ >> -> `Fun (bin_write_path_fun _loc id) | <:ctyp< $_$ -> $_$ >> -> failwith "bin_write_type: cannot convert functions to the binary protocol" | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> | <:ctyp< [= $row_fields$ ] >> -> bin_write_variant full_type_name _loc row_fields | <:ctyp< ! $parms$ . $tp$ >> -> bin_write_poly full_type_name _loc parms tp | _ -> prerr_endline ( get_loc_err _loc "bin_write_type: unknown type construct"); exit 1 (* Conversion of polymorphic types *) and bin_write_appl_fun full_type_name _loc tp1 tp2 = match bin_write_type full_type_name _loc tp1, bin_write_type full_type_name _loc tp2 with | `Fun <:expr< Bin_prot.Unsafe_write_c.bin_write_array >>, `Fun <:expr< Bin_prot.Unsafe_write_c.bin_write_float >> -> <:expr< Bin_prot.Unsafe_write_c.bin_write_float_array >> | `Fun fun_expr1, `Fun fun_expr2 -> <:expr< $fun_expr1$ $fun_expr2$ >> | `Fun fun_expr, `Match matching -> <:expr< $fun_expr$ (fun sptr eptr -> fun [ $matching$ ]) >> | _ -> assert false (* impossible *) (* Conversion of tuples and records *) and bin_write_args full_type_name _loc get_tp mk_patt tp = let rec loop i = function | el :: rest -> let tp = get_tp el in let v_name = "v" ^ string_of_int i in let v_expr = match bin_write_type full_type_name _loc tp with | `Fun fun_expr -> <:expr< $fun_expr$ sptr eptr $lid:v_name$ >> | `Match matchings -> <:expr< match $lid:v_name$ with [ $matchings$ ] >> in let patt = mk_patt _loc v_name el in if rest = [] then [patt], v_expr else let patts, in_expr = loop (i + 1) rest in patt :: patts, <:expr< let sptr = $v_expr$ in $in_expr$ >> | [] -> assert false (* impossible *) in loop 1 (list_of_ctyp tp []) and bin_write_tup_rec full_type_name _loc cnv_patts get_tp mk_patt tp = let patts, expr = bin_write_args full_type_name _loc get_tp mk_patt tp in `Match <:match_case< $cnv_patts patts$ -> $expr$ >> (* Conversion of tuples *) and bin_write_tuple full_type_name _loc tp = let cnv_patts patts = <:patt< ( $tup:paCom_of_list patts$ ) >> in let get_tp tp = tp in let mk_patt _loc v_name _ = <:patt< $lid:v_name$ >> in bin_write_tup_rec full_type_name _loc cnv_patts get_tp mk_patt tp (* Conversion of records *) and bin_write_record full_type_name _loc tp = let cnv_patts patts = <:patt< { $paSem_of_list patts$ } >> in let get_tp = function | <:ctyp< $_$ : mutable $tp$ >> | <:ctyp< $_$ : $tp$ >> -> tp | _ -> assert false (* impossible *) in let mk_patt _loc v_name = function | <:ctyp< $lid:r_name$ : $_$ >> -> <:patt< $lid:r_name$ = $lid:v_name$ >> | _ -> assert false (* impossible *) in bin_write_tup_rec full_type_name _loc cnv_patts get_tp mk_patt tp (* Conversion of variant types *) and bin_write_variant full_type_name _loc row_fields = let rec loop = function | <:ctyp< $tp1$ | $tp2$ >> -> <:match_case< $loop tp1$ | $loop tp2$ >> | <:ctyp< `$cnstr$ >> -> <:match_case< `$cnstr$ as v -> Bin_prot.Unsafe_write_c.bin_write_variant_tag sptr eptr v >> | <:ctyp< `$cnstr$ of $tp$ >> -> let write_args = match bin_write_type full_type_name _loc tp with | `Fun fun_expr -> <:expr< $fun_expr$ sptr eptr args >> | `Match matchings -> <:expr< match args with [ $matchings$ ] >> in <:match_case< `$cnstr$ args as v -> let sptr = Bin_prot.Unsafe_write_c.bin_write_variant_tag sptr eptr v in $write_args$ >> | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> | <:ctyp< [= $row_fields$ ] >> -> loop row_fields | <:ctyp< $tp1$ $tp2$ >> -> let id_path = Gen.get_appl_path _loc tp1 in let call = bin_write_appl_fun full_type_name _loc tp1 tp2 in <:match_case< #$id_path$ as v -> $call$ sptr eptr v >> | <:ctyp< $id:id$ >> | <:ctyp< #$id:id$ >> -> let call = match Gen.get_rev_id_path id [] with | tn :: path -> mk_abst_call _loc tn path | [] -> assert false (* impossible *) in <:match_case< #$id$ as v -> $call$ sptr eptr v >> | _ -> failwith "bin_write_variant: unknown type" in `Match (loop row_fields) (* Polymorphic record fields *) and bin_write_poly full_type_name _loc parms tp = let bindings = let mk_binding parm = <:binding< $lid:"_write_" ^ parm$ = fun _sptr _eptr _v -> raise (Bin_prot.Common.Poly_rec_write $str:full_type_name$) >> in List.map mk_binding (Gen.ty_var_list_of_ctyp parms []) in match bin_write_type full_type_name _loc tp with | `Fun fun_expr -> `Fun <:expr< let $list:bindings$ in $fun_expr$ >> | `Match matchings -> `Match <:match_case< arg -> let $list:bindings$ in match arg with [ $matchings$ ] >> (* Conversion of sum types *) let rec count_alts = function | <:ctyp< $tp1$ | $tp2$ >> -> count_alts tp1 + count_alts tp2 | _ -> 1 let bin_write_sum full_type_name _loc alts = let n_alts = count_alts alts in let write_tag = if n_alts <= 256 then <:expr< Bin_prot.Unsafe_write_c.bin_write_int_8bit sptr eptr >> else if n_alts <= 65536 then <:expr< Bin_prot.Unsafe_write_c.bin_write_int_16bit sptr eptr >> else ( prerr_endline ( get_loc_err _loc "bin_write_sum: too many alternatives (> 65536)"); exit 1) in let rec loop i = function | <:ctyp< $tp1$ | $tp2$ >> -> let i1, case1 = loop i tp1 in let i2, case2 = loop i1 tp2 in i2, <:match_case< $case1$ | $case2$ >> | <:ctyp< $uid:cnstr$ >> -> i + 1, <:match_case< $uid:cnstr$ -> $write_tag$ $`int:i$ >> | <:ctyp< $uid:cnstr$ of $tp$ >> -> let get_tp tp = tp in let mk_patt _loc v_name _ = <:patt< $lid:v_name$ >> in let patts, write_args = bin_write_args full_type_name _loc get_tp mk_patt tp in let args = match patts with | [patt] -> patt | _ -> <:patt< $tup:paCom_of_list patts$ >> in let case = <:match_case< $uid:cnstr$ $args$ -> let sptr = $write_tag$ $`int:i$ in $write_args$ >> in i + 1, case | <:ctyp< $_$ : $_$ >> as tp -> Gen.error tp ~fn:"bin_write_sum" ~msg:"GADTs are not supported by bin_prot" | tp -> Gen.unknown_type tp "bin_write_sum" in `Match (snd (loop 0 alts)) (* Empty types *) let bin_write_nil full_type_name _loc = `Fun <:expr< raise (Bin_prot.Common.Empty_type $str:full_type_name$) >> (* Generate code from type definitions *) let bin_write_td _loc type_name tps rhs = let full_type_name = sprintf "%s.%s" (get_conv_path ()) type_name in let is_nil = ref false in let int_body = let rec loop _loc = Gen.switch_tp_def ~alias:(bin_write_type full_type_name) ~sum:(bin_write_sum full_type_name) ~record:(bin_write_record full_type_name) ~variants:(bin_write_variant full_type_name) ~mani:(fun _loc _tp1 -> loop _loc) ~nil:(fun _loc -> is_nil := true; bin_write_nil full_type_name _loc) in match loop _loc rhs with | `Fun expr when !is_nil -> <:expr< fun _sptr _eptr _v -> $expr$ >> | `Fun fun_expr -> <:expr< fun sptr eptr v -> $fun_expr$ sptr eptr v >> | `Match matchings -> <:expr< fun sptr eptr -> fun [ $matchings$ ] >> in let tparam_cnvs = List.map ( (^) "_write_" *** Gen.get_tparam_id) tps in let mk_pat id = <:patt< $lid:id$ >> in let tparam_patts = List.map mk_pat tparam_cnvs in let int_call = "bin_write_" ^ type_name ^ "_" in let ext_fun = let ext_body = match int_body with | <:expr< fun sptr eptr v -> Bin_prot.Unsafe_write_c.$call$ sptr eptr v >> -> <:expr< Bin_prot.Write_ml.$call$ buf ~pos v >> | _ -> let app_call = let mk_expr name = <:expr< $lid:name$ >> in let tparam_exprs = List.map mk_expr tparam_cnvs in Gen.apply _loc <:expr< $lid:int_call$ >> tparam_exprs in <:expr< if Pervasives.(<) pos 0 then Bin_prot.Common.array_bound_error () else let buf_len = Bigarray.Array1.dim buf in if Pervasives.(>) pos buf_len then raise Bin_prot.Common.Buffer_short else let start = Bin_prot.Unsafe_common.get_sptr buf ~pos:0 in let sptr = Bin_prot.Unsafe_common.get_sptr buf ~pos in let eptr = Bin_prot.Unsafe_common.get_eptr buf ~pos:buf_len in let cur = $app_call$ sptr eptr v in Bin_prot.Unsafe_common.get_safe_buf_pos buf ~start ~cur >> in <:expr< fun buf ~pos v -> $ext_body$ >> in let ext_name = "bin_write_" ^ type_name in let size_name = "bin_size_" ^ type_name in ( <:binding< $lid:int_call$ = $Gen.abstract _loc tparam_patts int_body$ >>, ( <:binding< $lid:ext_name$ = $Gen.abstract _loc tparam_patts ext_fun$ >>, let size = let tparam_size_exprs = List.map (fun tp -> <:expr< $lid:"bin_writer_" ^ Gen.get_tparam_id tp$ .Bin_prot.Type_class.size >>) tps in let call = Gen.apply _loc <:expr< $lid:size_name$ >> tparam_size_exprs in <:expr< fun v -> $call$ v >> in let tparam_unsafe_write_exprs = List.map (fun tp -> <:expr< $lid:"bin_writer_" ^ Gen.get_tparam_id tp$ .Bin_prot.Type_class.unsafe_write >>) tps in let write = let call = Gen.apply _loc <:expr< $lid:ext_name$ >> tparam_unsafe_write_exprs in <:expr< fun buf ~pos v -> $call$ buf ~pos v >> in let unsafe_write = let call = Gen.apply _loc <:expr< $lid:int_call$ >> tparam_unsafe_write_exprs in <:expr< fun sptr eptr v -> $call$ sptr eptr v >> in let write = <:expr< { Bin_prot.Type_class. size = $size$; unsafe_write = $unsafe_write$; write = $write$; } >> in let tparam_writer_patts = List.map (fun tp -> <:patt< $lid:"bin_writer_" ^ Gen.get_tparam_id tp$ >>) tps in <:binding< $lid:"bin_writer_" ^ type_name$ = $Gen.abstract _loc tparam_writer_patts write$ >> ) ) let rec bin_write_tds acc = function | TyDcl (_loc, type_name, tps, rhs, _cl) -> bin_write_td _loc type_name tps rhs :: acc | TyAnd (_loc, tp1, tp2) -> bin_write_tds (bin_write_tds acc tp2) tp1 | _ -> assert false (* impossible *) let bin_write rec_ tds = let internals, externals1, externals2, recursive, _loc = match tds with | TyDcl (_loc, type_name, tps, rhs, _cl) -> let internal, (external1, external2) = bin_write_td _loc type_name tps rhs in [internal], [external1], [external2], rec_ && Gen.type_is_recursive type_name rhs, _loc | TyAnd (_loc, _, _) -> let res = bin_write_tds [] tds in let internals, many_externals = List.split res in let externals1, externals2 = List.split many_externals in internals, externals1, externals2, rec_, _loc | _ -> assert false (* impossible *) in let internals_item = if recursive then <:str_item< value rec $list:internals$ >> else <:str_item< value $list:internals$ >> in <:str_item< $Generate_bin_size.bin_size rec_ tds$; $internals_item$; value $list:externals1$; value $list:externals2$; >> (* Add code generator to the set of known generators *) let () = add_generator "bin_write" bin_write end (* Generator for converters of binary protocol to OCaml-values *) module Generate_bin_read = struct let mk_abst_call _loc tn ?(internal = false) rev_path = let tnp = let tnn = "bin_read_" ^ tn in if internal then tnn ^ "__" else tnn ^ "_" in <:expr< $id:Gen.ident_of_rev_path _loc (tnp :: rev_path)$ >> (* Conversion of type paths *) let bin_read_path_fun _loc id = match Gen.get_rev_id_path id [] with | tn :: rev_path -> mk_abst_call _loc tn rev_path | [] -> assert false (* no empty paths *) let get_closed_expr _loc = function | `Open expr -> <:expr< fun sptr_ptr eptr -> $expr$ >> | `Closed expr -> expr let get_open_expr _loc = function | `Open expr -> expr | `Closed expr -> <:expr< $expr$ sptr_ptr eptr >> (* Conversion of arguments *) let rec handle_arg_tp _loc full_type_name arg_tp = let n_args1, args, bindings = let rec arg_loop ai = function | <:ctyp< $tp1$ and $tp2$ >> -> let ai1, args1, abs1 = arg_loop ai tp1 in let ai2, args2, abs2 = arg_loop ai1 tp2 in ( ai2, <:expr< $args1$, $args2$ >>, <:binding< $abs1$ and $abs2$ >> ) | tp -> let f = get_open_expr _loc (bin_read_type full_type_name _loc tp) in let arg_name = "arg_" ^ string_of_int ai in ( ai + 1, <:expr< $lid:arg_name$ >>, <:binding< $lid:arg_name$ = $f$ >> ) in arg_loop 1 arg_tp in let args_expr = if n_args1 = 2 then <:expr< $args$ >> else <:expr< ( $tup:args$ ) >> in bindings, args_expr (* Conversion of types *) and bin_read_type full_type_name _loc = function | <:ctyp< $tp1$ $tp2$ >> -> let arg_expr = get_closed_expr _loc (bin_read_type full_type_name _loc tp2) in let expr = match bin_read_type full_type_name _loc tp1, arg_expr with | `Closed <:expr< Bin_prot.Unsafe_read_c.bin_read_array >>, <:expr< Bin_prot.Unsafe_read_c.bin_read_float >> -> `Closed <:expr< Bin_prot.Unsafe_read_c.bin_read_float_array >> | `Closed expr, _ -> `Closed <:expr< $expr$ $arg_expr$ >> | _ -> assert false (* impossible *) in expr | <:ctyp< ( $tup:tp$ ) >> -> bin_read_tuple full_type_name _loc tp | <:ctyp< '$parm$ >> -> `Closed <:expr< $lid:"_of__" ^ parm$ >> | <:ctyp< $id:id$ >> -> `Closed (bin_read_path_fun _loc id) | <:ctyp< $_$ -> $_$ >> -> failwith "bin_read_arrow: cannot convert functions" | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> | <:ctyp< [= $row_fields$ ] >> -> fst (bin_read_variant full_type_name _loc ?full_type:None row_fields) | <:ctyp< ! $parms$ . $poly_tp$ >> -> bin_read_poly full_type_name _loc parms poly_tp | _ -> prerr_endline ( get_loc_err _loc "bin_read_type: unknown type construct"); exit 1 (* Conversion of tuples *) and bin_read_tuple full_type_name _loc tps = let _, bindings, expr = let rec loop i = function | <:ctyp< $tp1$ * $tp2$ >> -> let i1, bs1, exprs1 = loop i tp1 in let i2, bs2, exprs2 = loop i1 tp2 in i2, <:binding< $bs1$ and $bs2$ >>, <:expr< $exprs1$, $exprs2$ >> | tp -> let v_name = "v" ^ string_of_int i in let expr = get_open_expr _loc (bin_read_type full_type_name _loc tp) in ( i + 1, <:binding< $lid:v_name$ = $expr$ >>, <:expr< $lid:v_name$ >> ) in loop 1 tps in `Open <:expr< let $bindings$ in ( $tup:expr$ ) >> (* Variant conversions *) (* Generate internal call *) and mk_internal_call full_type_name _loc = function | <:ctyp< $id:id$ >> | <:ctyp< #$id:id$ >> -> let call = match Gen.get_rev_id_path id [] with | tn :: rev_path -> mk_abst_call _loc tn ~internal:true rev_path | [] -> assert false (* impossible *) in call | <:ctyp< $tp1$ $tp2$ >> -> let arg_expr = get_closed_expr _loc (bin_read_type full_type_name _loc tp2) in <:expr< $mk_internal_call full_type_name _loc tp1$ $arg_expr$ >> | _ -> assert false (* impossible *) (* Generate matching code for variants *) and bin_read_variant full_type_name _loc ?full_type row_tp = let is_contained, full_type = match full_type with | None -> true, <:ctyp< [= $row_tp$ ] >> | Some full_type -> false, full_type in let atoms_only = ref true in let code = let mk_check_vint mcs = <:expr< match Bin_prot.Common.variant_of_int vint with [ $mcs$ ] >> in let mk_try_next_expr call next_expr = <:expr< try $call$ with [ Bin_prot.Common.No_variant_match -> $next_expr$ ] >> in let raise_nvm = <:expr< raise Bin_prot.Common.No_variant_match >> in let rec loop_many next = function | h :: t -> loop_one next t h | [] -> match next with | `Matches mcs -> mk_check_vint mcs | `Expr expr -> expr | `None -> raise_nvm and loop_one next t = function | <:ctyp< `$cnstr$ >> -> let this_mc = <:match_case< `$cnstr$ as tag -> tag >> in add_mc next this_mc t | <:ctyp< `$cnstr$ of $arg_tp$ >> -> atoms_only := false; let bnds, args_expr = handle_arg_tp _loc full_type_name arg_tp in let rhs = <:expr< let $bnds$ in `$cnstr$ $args_expr$ >> in let this_mc = <:match_case< `$cnstr$ -> $rhs$ >> in add_mc next this_mc t | (<:ctyp< $id:_$ >> | <:ctyp< $_$ $_$ >> | <:ctyp< #$id:_$ >>) as inh -> atoms_only := false; let call = <:expr< ( $mk_internal_call full_type_name _loc inh$ sptr_ptr eptr vint :> $full_type$ ) >> in let expr = match next with | `Matches mcs -> mk_try_next_expr call (mk_check_vint mcs) | `Expr expr -> mk_try_next_expr call expr | `None -> call in loop_many (`Expr expr) t | _ -> assert false (* impossible *) and add_mc next this_mc t = let next_mcs = match next with | `Matches mcs -> mcs | `Expr expr -> <:match_case< _ -> $expr$ >> | `None -> <:match_case< _ -> $raise_nvm$ >> in loop_many (`Matches <:match_case< $this_mc$ | $next_mcs$ >>) t in loop_many `None (List.rev (list_of_ctyp row_tp [])) in let res = if is_contained then `Open <:expr< let vint = Bin_prot.Unsafe_read_c.bin_read_variant_int sptr_ptr eptr in try $code$ with [ Bin_prot.Common.No_variant_match -> raise ( Bin_prot.Unsafe_read_c.Error ( Bin_prot.Common.ReadError.Variant $str:full_type_name$)) ] >> else `Open code in res, !atoms_only (* Polymorphic record field conversion *) and bin_read_poly full_type_name _loc parms tp = let bindings = let mk_binding parm = <:binding< $lid:"_of__" ^ parm$ = fun _sptr_ptr _eptr -> raise ( Bin_prot.Unsafe_read_c.Error ( Bin_prot.Common.ReadError.Poly_rec_bound $str:full_type_name$)) >> in List.map mk_binding (Gen.ty_var_list_of_ctyp parms []) in let f = get_open_expr _loc (bin_read_type full_type_name _loc tp) in `Open <:expr< let $list:bindings$ in $f$ >> (* Sum type conversions *) let bin_read_sum full_type_name _loc alts = let rec loop mi = function | <:ctyp< $tp1$ | $tp2$ >> -> let i1, mcs1 = loop mi tp1 in let i2, mcs2 = loop i1 tp2 in i2, <:match_case< $mcs1$ | $mcs2$ >> | <:ctyp< $uid:atom$ >> -> mi + 1, <:match_case< $`int:mi$ -> $uid:atom$ >> | <:ctyp< $uid:atom$ of $arg_tp$ >> -> let bindings, args_expr = handle_arg_tp _loc full_type_name arg_tp in let rhs = <:expr< let $bindings$ in $uid:atom$ $args_expr$ >> in mi + 1, <:match_case< $`int:mi$ -> $rhs$ >> | <:ctyp< $_$ : $_$ >> as tp -> Gen.error tp ~fn:"bin_read_sum" ~msg:"GADTs are not supported by bin_prot" | tp -> Gen.unknown_type tp "bin_read_sum" in let n_alts, mcs = loop 0 alts in let read_fun = if n_alts <= 256 then <:expr< Bin_prot.Unsafe_read_c.bin_read_int_8bit >> else if n_alts <= 65536 then <:expr< Bin_prot.Unsafe_read_c.bin_read_int_16bit >> else ( prerr_endline ( get_loc_err _loc "bin_read_sum: more than 65536 constructors"); exit 1) in `Open <:expr< match $read_fun$ sptr_ptr eptr with [ $mcs$ | _ -> raise ( Bin_prot.Unsafe_read_c.Error ( Bin_prot.Common.ReadError.Sum_tag $str:full_type_name$)) ] >> (* Record conversions *) let bin_read_record full_type_name _loc tps = let bindings, rec_bindings = let rec loop = function | <:ctyp< $tp1$; $tp2$ >> -> let bs1, rec_bs1 = loop tp1 in let bs2, rec_bs2 = loop tp2 in ( <:binding< $bs1$ and $bs2$ >>, <:rec_binding< $rec_bs1$; $rec_bs2$ >> ) | <:ctyp< $lid:field_name$ : mutable $tp$ >> | <:ctyp< $lid:field_name$ : $tp$ >> -> let v_name = "v_" ^ field_name in let f = get_open_expr _loc (bin_read_type full_type_name _loc tp) in ( <:binding< $lid:v_name$ = $f$ >>, <:rec_binding< $lid:field_name$ = $lid:v_name$ >> ) | _ -> assert false (* impossible *) in loop tps in `Open <:expr< let $bindings$ in { $rec_bindings$ } >> (* Empty types *) let bin_read_nil full_type_name _loc = `Closed <:expr< fun _sptr_ptr _eptr -> raise ( Bin_prot.Unsafe_read_c.Error (Bin_prot.Common.ReadError.Empty_type $str:full_type_name$)) >> (* Generate code from type definitions *) let bin_read_td _loc rec_ type_name tps rhs = let full_type_name = sprintf "%s.%s" (get_conv_path ()) type_name in let full_type = mk_full_type _loc type_name tps in let is_alias_ref = ref false in let handle_alias _loc tp = is_alias_ref := true; bin_read_type full_type_name _loc tp in let is_variant_ref = ref false in let atoms_only_ref = ref true in let handle_variant _loc tp = is_variant_ref := true; let res, atoms_only = bin_read_variant full_type_name ~full_type _loc tp in atoms_only_ref := atoms_only; res in let arg_patts, arg_exprs = List.split ( List.map (function tp -> let name = "_of__" ^ Gen.get_tparam_id tp in <:patt< $lid:name$ >>, <:expr< $lid:name$ >> ) tps) in let oc_body = let rec loop _loc = Gen.switch_tp_def ~alias:handle_alias ~sum:(bin_read_sum full_type_name) ~record:(bin_read_record full_type_name) ~variants:handle_variant ~mani:(fun _loc _tp1 -> loop _loc) ~nil:(bin_read_nil type_name) in loop _loc rhs in let variant_int_call = let maybe_poly_var_name = "bin_read_" ^ type_name ^ "__" in let maybe_poly_var_expr = <:expr< $lid:maybe_poly_var_name$ >> in <:expr< let vint = Bin_prot.Unsafe_read_c.bin_read_variant_int sptr_ptr eptr in $Gen.apply _loc maybe_poly_var_expr arg_exprs$ sptr_ptr eptr vint >> in let user_binding_name = "bin_read_" ^ type_name in let user_binding = let exc_handling = let normal_exc_handling = <:match_case< Bin_prot.Unsafe_read_c.Error ( Bin_prot.Common.ReadError.Variant _ as err) -> let err_pos4 = Bin_prot.Unsafe_common.dealloc_sptr_ptr buf sptr_ptr in let err_pos = Pervasives.(-) err_pos4 4 in Bin_prot.Common.raise_read_error err err_pos | Bin_prot.Unsafe_read_c.Error err -> let err_pos = Bin_prot.Unsafe_common.dealloc_sptr_ptr buf sptr_ptr in Bin_prot.Common.raise_read_error err err_pos | exc -> let err_pos = Bin_prot.Unsafe_common.dealloc_sptr_ptr buf sptr_ptr in Bin_prot.Common.raise_read_exc exc err_pos >> in if !is_variant_ref then <:match_case< Bin_prot.Common.No_variant_match -> let err_pos4 = Bin_prot.Unsafe_common.dealloc_sptr_ptr buf sptr_ptr in let err_pos = Pervasives.(-) err_pos4 4 in let err = Bin_prot.Common.ReadError.Variant $str:full_type_name$ in Bin_prot.Common.raise_read_error err err_pos | $normal_exc_handling$ >> else normal_exc_handling in let abst_call = if !is_alias_ref && rec_ then (* this inlining is provoking captures in the generated code when using nonrec, so disabling it *) match oc_body with | `Closed expr -> <:expr< $expr$ sptr_ptr eptr >> | `Open body -> body else if !is_variant_ref then variant_int_call else let abst_name = "bin_read_" ^ type_name ^ "_" in let abst_expr = <:expr< $lid:abst_name$ >> in <:expr< $Gen.apply _loc abst_expr arg_exprs$ sptr_ptr eptr >> in let user_fun = let user_body = match abst_call with | <:expr< Bin_prot.Unsafe_read_c.$call$ sptr_ptr eptr >> -> <:expr< ((Bin_prot.Read_ml.$call$ buf ~pos_ref) : $full_type$) >> | _ -> <:expr< let pos = !pos_ref in if Pervasives.(<) pos 0 then Bin_prot.Common.array_bound_error () else let buf_len = Bigarray.Array1.dim buf in if Pervasives.(>) pos buf_len then raise Bin_prot.Common.Buffer_short else let sptr_ptr = Bin_prot.Unsafe_common.alloc_sptr_ptr buf ~pos in let eptr = Bin_prot.Unsafe_common.get_eptr buf ~pos:buf_len in let v = try $abst_call$ with [ $exc_handling$ ] in let cur = Bin_prot.Unsafe_common.dealloc_sptr_ptr buf sptr_ptr in do { pos_ref.contents := cur; (v : $full_type$) } >> in Gen.abstract _loc arg_patts <:expr< fun buf ~pos_ref -> $user_body$ >> in <:binding< $lid:user_binding_name$ = $user_fun$ >> in let unsafe_read_name = "bin_read_" ^ type_name ^ "_" in let abst_binding = let abst_body = if !is_alias_ref then match oc_body with | `Closed f -> <:expr< fun sptr_ptr eptr -> $f$ sptr_ptr eptr >> | `Open body -> <:expr< fun sptr_ptr eptr -> $body$ >> else if !is_variant_ref then <:expr< fun sptr_ptr eptr -> try $variant_int_call$ with [ Bin_prot.Common.No_variant_match -> raise (Bin_prot.Unsafe_read_c.Error ( Bin_prot.Common.ReadError.Variant $str:full_type_name$)) ] >> else match oc_body with | `Open body -> <:expr< fun sptr_ptr eptr -> $body$ >> | `Closed f -> <:expr< $f$ >> in <:binding< $lid:unsafe_read_name$ = $Gen.abstract _loc arg_patts abst_body$ >> in let unsafe_vtag_read_name = "bin_read_" ^ type_name ^ "__" in let maybe_poly_var_binding = let maybe_poly_var_body = let wrong_type = <:expr< fun _sptr_ptr _eptr _vint -> Bin_prot.Unsafe_read_c.raise_variant_wrong_type $str:full_type_name$ >> in if !is_alias_ref then match oc_body with | `Closed call -> let rec rewrite_call cnv = function | <:expr< $f$ $arg$ >> -> rewrite_call (fun new_f -> cnv (<:expr< $new_f$ $arg$ >>)) f | <:expr< Bin_prot.Unsafe_read_c.$_$ >> -> wrong_type | <:expr< $lid:name$ >> when name.[0] = '_' && name.[1] = 'o' -> <:expr< fun _sptr_ptr _eptr _vint -> raise ( Bin_prot.Unsafe_read_c.Error (Bin_prot.Common.ReadError.Silly_type $str:full_type_name$)) >> | <:expr< $id:id$ >> -> (match Gen.get_rev_id_path id [] with | call :: rest -> let expr = <:expr< $id:Gen.ident_of_rev_path _loc ((call ^ "_") :: rest)$ >> in <:expr< fun sptr_ptr eptr vint -> $cnv expr$ sptr_ptr eptr vint >> | _ -> assert false) (* impossible *) | _ -> assert false (* impossible *) in rewrite_call (fun x -> x) call | _ -> wrong_type else if !is_variant_ref then match oc_body with | `Open body when !atoms_only_ref -> <:expr< fun _sptr_ptr _eptr vint -> $body$ >> | `Open body -> <:expr< fun sptr_ptr eptr vint -> $body$ >> | _ -> assert false (* impossible *) else wrong_type in let full_body = Gen.abstract _loc arg_patts maybe_poly_var_body in <:binding< $lid:unsafe_vtag_read_name$ = $full_body$ >> in let tparam_unsafe_read_exprs = List.map (fun tp -> <:expr< $lid:"bin_reader_" ^ Gen.get_tparam_id tp$ .Bin_prot.Type_class.unsafe_read >>) tps in let read = let call = Gen.apply _loc <:expr< $lid:user_binding_name$ >> tparam_unsafe_read_exprs in <:expr< fun buf ~pos_ref -> $call$ buf ~pos_ref >> in let unsafe_read = let call = Gen.apply _loc <:expr< $lid:unsafe_read_name$ >> tparam_unsafe_read_exprs in <:expr< fun sptr_ptr eptr -> $call$ sptr_ptr eptr >> in let unsafe_vtag_read = let call = Gen.apply _loc <:expr< $lid:unsafe_vtag_read_name$ >> tparam_unsafe_read_exprs in <:expr< fun sptr_ptr eptr vtag -> $call$ sptr_ptr eptr vtag >> in let reader = <:expr< { Bin_prot.Type_class. read = $read$; unsafe_read = $unsafe_read$; unsafe_vtag_read = $unsafe_vtag_read$; } >> in let tparam_reader_patts = List.map (fun tp -> <:patt< $lid:"bin_reader_" ^ Gen.get_tparam_id tp$ >>) tps in let reader_binding = <:binding< $lid:"bin_reader_" ^ type_name$ = ($Gen.abstract _loc tparam_reader_patts reader$) >> in ( ( maybe_poly_var_binding, abst_binding ), ( user_binding, reader_binding ) ) let rec bin_read_tds rec_ acc = function | TyDcl (_loc, type_name, tps, rhs, _cl) -> bin_read_td _loc rec_ type_name tps rhs :: acc | TyAnd (_loc, tp1, tp2) -> bin_read_tds rec_ (bin_read_tds rec_ acc tp2) tp1 | _ -> assert false (* impossible *) (* Generate code from type definitions *) let bin_read rec_ tds = let res, recursive, _loc = match tds with | TyDcl (_loc, type_name, tps, rhs, _cl) -> let res = bin_read_td _loc rec_ type_name tps rhs in [res], rec_ && Gen.type_is_recursive type_name rhs, _loc | TyAnd (_loc, _, _) -> bin_read_tds rec_ [] tds, rec_, _loc | _ -> assert false (* impossible *) in let poly_abst, user_bindings_readers = List.split res in let user_bindings, readers = List.split user_bindings_readers in let internal_str_item = if recursive then (* Improve code locality *) let cnv (maybe_poly_var_binding, abst_binding) = <:binding< $maybe_poly_var_binding$ and $abst_binding$ >> in let internal_bindings = List.map cnv poly_abst in <:str_item< value rec $list:internal_bindings$ >> else (* Improve code locality *) let cnv (maybe_poly_var_binding, abst_binding) = <:str_item< value $maybe_poly_var_binding$; value $abst_binding$ >> in let internal_items = List.map cnv poly_abst in <:str_item< $list:internal_items$ >> in <:str_item< $internal_str_item$; value $list:user_bindings$; value $list:readers$; >> (* Add code generator to the set of known generators *) let () = add_generator "bin_read" bin_read end (* Generator for binary protocol type classes *) module Generate_tp_class = struct let bin_tp_class_td _loc type_name tps _rhs = let tparam_cnvs = List.map (fun tp -> "bin_" ^ Gen.get_tparam_id tp) tps in let mk_pat id = <:patt< $lid:id$ >> in let tparam_patts = List.map mk_pat tparam_cnvs in let writer = let tparam_exprs = List.map (fun tp -> <:expr< $lid:"bin_" ^ Gen.get_tparam_id tp$ .Bin_prot.Type_class.writer >>) tps in Gen.apply _loc <:expr< $lid:"bin_writer_" ^ type_name$ >> tparam_exprs in let reader = let tparam_exprs = List.map (fun tp -> <:expr< $lid:"bin_" ^ Gen.get_tparam_id tp$ .Bin_prot.Type_class.reader >>) tps in Gen.apply _loc <:expr< $lid:"bin_reader_" ^ type_name$ >> tparam_exprs in let body = <:expr< { Bin_prot.Type_class. writer = $writer$; reader = $reader$; } >> in <:binding< $lid:"bin_" ^ type_name$ = $Gen.abstract _loc tparam_patts body$ >> let rec bin_tp_class_tds acc = function | TyDcl (_loc, type_name, tps, rhs, _cl) -> bin_tp_class_td _loc type_name tps rhs :: acc | TyAnd (_loc, tp1, tp2) -> bin_tp_class_tds (bin_tp_class_tds acc tp2) tp1 | _ -> assert false (* impossible *) (* Generate code from type definitions *) let bin_tp_class _rec tds = let _loc = Loc.ghost in <:str_item< value $list:bin_tp_class_tds [] tds$ >> (* Add code generator to the set of known generators *) let () = add_generator "bin_type_class" bin_tp_class end (* Add "bin_read", "bin_write" and "bin_type_class" as "bin_io" to the set of generators *) module Str_generate = struct let () = add_generator "bin_io" (fun rec_ tds -> let _loc = Loc.ghost in let bin_write = Generate_bin_write.bin_write rec_ tds in let bin_read = Generate_bin_read.bin_read rec_ tds in let type_class = Generate_tp_class.bin_tp_class rec_ tds in <:str_item< $bin_write$; $bin_read$; $type_class$ >>) end bin_prot-109.30.00/syntax/pa_bin_prot.mli000066400000000000000000000001111216015522300201530ustar00rootroot00000000000000(** Pa_bin_prot: Preprocessing Module for a Type Safe Binary Protocol *) bin_prot-109.30.00/syntax/pa_bin_prot.mllib000066400000000000000000000001401216015522300204730ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 0f1a15b21854bc6a0f9c98fd964cb6fc) Pa_bin_prot # OASIS_STOP