pax_global_header00006660000000000000000000000064125646107410014520gustar00rootroot0000000000000052 comment=b932a3a0905f4a33dcc8e52692708c7e0c37a245 bin_prot-113.00.00/000077500000000000000000000000001256461074100136365ustar00rootroot00000000000000bin_prot-113.00.00/.gitignore000066400000000000000000000001021256461074100156170ustar00rootroot00000000000000_build/ /setup.data /setup.log /*.exe /*.docdir /*.native /*.byte bin_prot-113.00.00/CHANGES.md000066400000000000000000000206061256461074100152340ustar00rootroot00000000000000## 113.00.00 - Switched build to use =config.h= rather than the command-line for preprocessor variables. - Switched from `ARCH_SIXTYFOUR` to `JSC_ARCH_SIXTYFOUR`. - Fixed to support 32-bit integers, which are used in `js_of_ocaml`. Do not make too many assumptions on integer size. Integers are 32bit in Javascript. Do not use the "get_float_offset" hack on 32bit as it cannot be implemented in javascript. ## 112.35.00 - Sped up `bin_io` of `float array`. `Bin_prot` already had special fast handling for `float array`'s but `with bin_io` did not use it except for the special type `float_array`. Now, there is fast handling for `float array` and its aliases, for example `price array` when `type price = float`. - Changed `Size.bin_size_array`, `Write.bin_write_array` and `Read.bin_read_array` short circuit to the fast path when it detects that `float array` is handled. Each of these functions receives a function for handling array elements and short circuits when the function for handling elements is equal to the function for handling floats, using physical equality of closures. - To cause short circuiting for aliases of `float`, changed `bin_io` so that aliased `bin_io` functions are equal the the `bin_io` functions of the original type. That is an optimization for itself regardless whether it's used for `float`. Before this change, every function generated for aliases were eta-expanded leading to different closures at runtime for each type. Short circuiting needs to apply to the handling function rather than to the value at hand because: * the value is available only in `size` and `write`, and we need a way to make `read` work as well. * even when the value is a float at runtime, the handling of a specific float alias may have been overridden by a custom one. Made a slight improvement to `bin_read_float_array`: since the array is going to be filled with read values, there is no need to fill it with `0.` after allocation: let next = pos + size in check_next buf next; -| let arr = Array.create len 0. in +| let arr = Array.make_float len in unsafe_blit_buf_float_array buf arr ~src_pos:pos ~dst_pos:0 ~len; pos_ref := next; The difference in speed when optimal and non optimal way of handling floats is used: | Name | Time/Run | mWd/Run | mjWd/Run | |--------------------------------------------|-------------|-----------|----------| | [bench.ml:float array] size non optimal | 3_403.80ns | 2_000.00w | | | [bench.ml:float array] size float_array | 5.55ns | | | | [bench.ml:float array] size Price.t array | 6.18ns | | | | [bench.ml:float array] write non optimal | 7_839.89ns | 2_000.00w | | | [bench.ml:float array] write float_array | 292.42ns | | | | [bench.ml:float array] write Price.t array | 293.16ns | | | | [bench.ml:float array] read non optimal | 9_665.06ns | 2_002.00w | 1.00kw | | [bench.ml:float array] read float_array | 461.01ns | 2.00w | 1.00kw | | [bench.ml:float array] read Price.t array | 449.43ns | 2.00w | 1.00kw | There is no observed speed penalty for runtime check for short circuiting. The following benchmark shows the speed of handling `int array` without and with the check: | Name | Time/Run | mWd/Run | mjWd/Run | |--------------------------------------------|-------------|-----------|----------| | [bench.ml:float array] int array size | 3_910.64ns | | | | [bench.ml:float array] int array write | 6_548.40ns | | | | [bench.ml:float array] int array read | 14_928.11ns | 2.00w | 1.00kw | | Name | Time/Run | mWd/Run | mjWd/Run | |--------------------------------------------|-------------|-----------|----------| | [bench.ml:float array] int array size | 3_906.86ns | | | | [bench.ml:float array] int array write | 5_874.63ns | | | | [bench.ml:float array] int array read | 14_225.06ns | 2.00w | 1.00kw | ## 112.24.00 Minor commit: comments. ## 112.17.00 - Added `Bin_prot.Blob`, formerly known as `Core_extended.Wrapped`, which has efficient handling of size-prefixed bin-io values in cases where serialization can be bypassed. ## 112.06.00 - Sped up `float` and `float array` operations. - Removed a use of `Obj.magic` in code generated by `pa_bin_prot` for polymorphic variants that led to memory unsafety. Previously, `pa_bin_prot` generated this kind of code for polymorphic variants: match Obj.magic (read_int buf pos) with | `A as x -> x | `B as x -> x | `C -> `C (read_float buf pos) | _ -> fail and this caused the compiler to assume the result is an immediate value. To fix this we removed the `as x -> x` and used the computed integer hash. ## 112.01.00 - In `Write`, improved some OCaml macros to name values and avoid calling C functions multiple times. ## 111.03.00 - Fixed build on ARM. ## 109.53.00 - Bump version number ## 109.47.00 - Compilation fix for 32-bit systems ## 109.44.00 - Remove "unwrapped" pointers used by `Bin_prot`, with the bug from 109.41 fixed. Unwrapped pointers cannot coexist with the remove-page-table optimization. Removed all the C stubs for reading/writing and used instead either the new primitives of the next OCaml or standard OCaml code reading/writing integers byte by byte. Since we don't have unsafe/safe functions anymore but only safe ones, removed all the `bin_{read,write}_t_` functions. Also renamed `bin_read_t__` to `__bin_read_t__` for the same reason as sexplib: to avoid confusion with the function generated for `t_` and hide it in the toplevel. ## 109.42.00 - Backed out the changes introduced in 109.41 ## 109.41.00 - Remove all uses of "unwrapped" pointers Unwrapped pointers cannot coexist with the remove-page-table optimization. Removed all the C stubs for reading/writing and used instead either the new primitives of the next OCaml or standard OCaml code reading/writing integers byte by byte. Since we don't have unsafe/safe functions anymore but only safe ones, removed all the `bin_{read,write}_t_` functions. Also renamed `bin_read_t__` to `__bin_read_t__` for the same reason as sexplib: to avoid confusion with the function generated for `t_` and hide it in the toplevel. ## 109.10.00 - Improved error messages in presence of GADTs. ## 2012-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. bin_prot-113.00.00/COPYRIGHT.txt000066400000000000000000000007701256461074100157530ustar00rootroot00000000000000Most 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 Group, LLC 1 New York Plaza, 33rd Floor New York, NY 10004 USA bin_prot-113.00.00/INRIA-DISCLAIMER.txt000066400000000000000000000013321256461074100166520ustar00rootroot00000000000000THIS 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-113.00.00/INSTALL.txt000066400000000000000000000017501256461074100155100ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: d1f07a815bedbff8347f55251af56ce8) *) 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 * 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-113.00.00/LICENSE-Tywith.txt000066400000000000000000000030101256461074100167410ustar00rootroot00000000000000--------------------------------------------------------------------------- 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-113.00.00/LICENSE.txt000066400000000000000000000261361256461074100154710ustar00rootroot00000000000000 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-113.00.00/Makefile000066400000000000000000000025121256461074100152760ustar00rootroot00000000000000# 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 grep -v '^#' 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-113.00.00/README.md000066400000000000000000000413011256461074100151140ustar00rootroot00000000000000`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](https://ocaml.janestreet.com/ocaml-core/latest/doc/bin_prot/). 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 Group, LLC Up-to-date information should be available at: * bin_prot-113.00.00/THIRD-PARTY.txt000066400000000000000000000013601256461074100161460ustar00rootroot00000000000000The 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-113.00.00/TODO.txt000066400000000000000000000000711256461074100151420ustar00rootroot00000000000000Testing: bin_write_int_{8,16,32,64}bit bin_size_... bin_prot-113.00.00/_oasis000066400000000000000000000050761256461074100150460ustar00rootroot00000000000000OASISFormat: 0.3 OCamlVersion: >= 4.00.0 FindlibVersion: >= 1.3.2 Name: bin_prot Version: 113.00.00 Synopsis: bin_prot - binary protocol generator Authors: Jane Street Group, LLC Copyrights: (C) 2008-2013 Jane Street Group LLC Maintainers: Jane Street Group, 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 _build/ Library bin_prot Path: lib Pack: true Modules: Binable, Nat0, Common, Size, Write, Read, Std, Type_class, Utils CSources: config.h, blit_stubs.c, float_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: 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: test Executable mac_test Path: 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: test Executable example Path: test MainIs: example.ml Build$: flag(tests) Install: false CompiledObject: best BuildDepends: bin_prot,bin_prot.syntax bin_prot-113.00.00/_tags000066400000000000000000000057141256461074100146650ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: c32f9c2175ceb2a06fe9208809f482c6) # 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 true: annot, bin_annot <**/.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/size.cmx": for-pack(Bin_prot) "lib/write.cmx": for-pack(Bin_prot) "lib/read.cmx": for-pack(Bin_prot) "lib/std.cmx": for-pack(Bin_prot) "lib/type_class.cmx": for-pack(Bin_prot) "lib/utils.cmx": for-pack(Bin_prot) : use_libbin_prot_stubs : package(bigarray) : package(unix) "lib/blit_stubs.c": package(bigarray) "lib/blit_stubs.c": package(unix) "lib/float_stubs.c": package(bigarray) "lib/float_stubs.c": package(unix) # Library pa_bin_prot "syntax/pa_bin_prot.cmxs": use_pa_bin_prot : package(camlp4.extend) : package(camlp4.quotations) : package(type_conv) # Executable test_runner : package(bigarray) : package(camlp4.extend) : package(camlp4.quotations) : package(oUnit) : package(type_conv) : package(unix) : use_bin_prot : use_pa_bin_prot : package(oUnit) : custom # Executable mac_test : package(bigarray) : package(camlp4.extend) : package(camlp4.quotations) : package(type_conv) : package(unix) : use_bin_prot : use_pa_bin_prot : custom # Executable example : package(bigarray) : package(camlp4.extend) : package(camlp4.quotations) : package(type_conv) : package(unix) : use_bin_prot : use_pa_bin_prot : package(bigarray) : package(camlp4.extend) : package(camlp4.quotations) : package(type_conv) : package(unix) : use_bin_prot : use_pa_bin_prot # OASIS_STOP :cpp :mlh : syntax_camlp4o : syntax_camlp4o bin_prot-113.00.00/bench/000077500000000000000000000000001256461074100147155ustar00rootroot00000000000000bin_prot-113.00.00/bench/bench.ml000066400000000000000000000042311256461074100163260ustar00rootroot00000000000000open Bin_prot open Core.Std BENCH_MODULE "float array" = struct let a = Array.create ~len:1000 0. let buf = let buf = Common.create_buf (1000 * 8 + 8) in let _ = Write.bin_write_float_array buf ~pos:0 a in buf module Price = struct type t = float with bin_io end let price_array : Price.t array = Array.create ~len:1000 0. let size_float f = Size.bin_size_float f BENCH "size non optimal" = Size.bin_size_array size_float a BENCH "size float array" = Size.bin_size_float_array a BENCH "size Price.t array" = Size.bin_size_array Price.bin_size_t price_array let write_float buf ~pos f = Write.bin_write_float buf ~pos f BENCH "write non optimal" = let _ = Write.bin_write_array write_float buf ~pos:0 a in () BENCH "write float array" = let _ = Write.bin_write_float_array buf ~pos:0 a in () BENCH "write Price.t array" = let _ = Write.bin_write_array Price.bin_write_t buf ~pos:0 a in () let read_float buf ~pos_ref = Read.bin_read_float buf ~pos_ref BENCH "read non optimal" = let pos_ref = ref 0 in let _ = Read.bin_read_array read_float buf ~pos_ref in () BENCH "read float array" = let pos_ref = ref 0 in let _ = Read.bin_read_float_array buf ~pos_ref in () BENCH "read Price.t array" = let pos_ref = ref 0 in let _ = Read.bin_read_array Price.bin_read_t buf ~pos_ref in () let int_array = Array.create ~len:1000 0 BENCH "int array size" = Size.bin_size_array Size.bin_size_int int_array BENCH "int array write" = let _ = Write.bin_write_array Write.bin_write_int buf ~pos:0 int_array in () BENCH "int array read" = let pos_ref = ref 0 in let _ = Read.bin_read_array Read.bin_read_int buf ~pos_ref in () module Book = struct type t = { a : Price.t array; } with bin_io end let book = { Book.a = Array.create ~len:1000 0. } let buf = let buf = Common.create_buf (2100 * 8) in let _ = Book.bin_write_t buf ~pos:0 book in buf BENCH "size field" = Book.bin_size_t book BENCH "write field" = Book.bin_write_t buf ~pos:0 book BENCH "read field" = let pos_ref = ref 0 in let _ = Book.bin_read_t buf ~pos_ref in () end bin_prot-113.00.00/config/000077500000000000000000000000001256461074100151035ustar00rootroot00000000000000bin_prot-113.00.00/config/arch.sh000077500000000000000000000006531256461074100163630ustar00rootroot00000000000000#!/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-113.00.00/configure000077500000000000000000000005531256461074100155500ustar00rootroot00000000000000#!/bin/sh # OASIS_START # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 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-113.00.00/lib/000077500000000000000000000000001256461074100144045ustar00rootroot00000000000000bin_prot-113.00.00/lib/META000066400000000000000000000013741256461074100150620ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 0031f26a552d94c7bc77940c79d9fa76) version = "113.00.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 = "113.00.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" archive(syntax, preprocessor, native) = "pa_bin_prot.cmxa" archive(syntax, preprocessor, native, plugin) = "pa_bin_prot.cmxs" exists_if = "pa_bin_prot.cma" ) # OASIS_STOP bin_prot-113.00.00/lib/bin_prot.mldylib000066400000000000000000000001351256461074100175750ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 1bc02777168ae4a46f0c5dd79137bf48) Bin_prot # OASIS_STOP bin_prot-113.00.00/lib/bin_prot.mllib000066400000000000000000000001351256461074100172400ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 1bc02777168ae4a46f0c5dd79137bf48) Bin_prot # OASIS_STOP bin_prot-113.00.00/lib/bin_prot.mlpack000066400000000000000000000002151256461074100174070ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: b1c5d779fd874c679249632e75d80332) Binable Nat0 Common Size Write Read Std Type_class Utils # OASIS_STOP bin_prot-113.00.00/lib/binable.ml000066400000000000000000000027201256461074100163330ustar00rootroot00000000000000(* 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 Write.writer val bin_read_t : t Read.reader (** This function only needs implementation if [t] exposed to be a polymorphic variant. Despite what the type reads, this does *not* produce a function after reading; instead it takes the constructor tag (int) before reading and reads the rest of the variant [t] afterwards. *) val __bin_read_t__ : (int -> t) Read.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) Write.writer1 val bin_read_t : ('a, 'a t) Read.reader1 val __bin_read_t__ : ('a, int -> 'a t) Read.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) Write.writer2 val bin_read_t : ('a, 'b, ('a, 'b) t) Read.reader2 val __bin_read_t__ : ('a, 'b, int -> ('a, 'b) t) Read.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-113.00.00/lib/blit_stubs.c000066400000000000000000000051271256461074100167270ustar00rootroot00000000000000/* Blitting between buffers/strings/float arrays */ #include #include #include #include #include #if defined(__GNUC__) && __GNUC__ >= 3 # ifndef __likely # define likely(x) __builtin_expect (!!(x), 1) # endif # ifndef __unlikely # define unlikely(x) __builtin_expect (!!(x), 0) # endif #else # ifndef __likely # define likely(x) (x) # endif # ifndef __unlikely # define unlikely(x) (x) # endif #endif #define get_buf(v_buf, v_pos) (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; } CAMLprim value bin_prot_blit_float_array_buf_stub( value v_src_pos, value v_arr, value v_dst_pos, value v_buf, value v_len) { char *arr = (char*)v_arr + Long_val(v_src_pos) * sizeof(double); char *buf = get_buf(v_buf, v_dst_pos); memcpy(buf, arr, (size_t) (Long_val(v_len) * sizeof(double))); return Val_unit; } CAMLprim value bin_prot_blit_buf_float_array_stub( value v_src_pos, value v_buf, value v_dst_pos, value v_arr, value v_len) { char *buf = get_buf(v_buf, v_src_pos); char *arr = (char*)v_arr + Long_val(v_dst_pos) * sizeof(double); memcpy(arr, buf, (size_t) (Long_val(v_len) * sizeof(double))); return Val_unit; } bin_prot-113.00.00/lib/blob.ml000066400000000000000000000064441256461074100156640ustar00rootroot00000000000000open Common module Opaque = struct (* [buf] is the bin-io data excluding the size header. When (de-)serialized, the size header is included. *) type t = buf let bin_size_t t = Utils.size_header_length + (buf_len t) let bin_write_t buf ~pos t = let size = buf_len t in let pos = Utils.bin_write_size_header buf ~pos size in blit_buf ~src:t ~src_pos:0 ~dst:buf ~dst_pos:pos size; pos + size let bin_read_t buf ~pos_ref = let size = Utils.bin_read_size_header buf ~pos_ref in let t = create_buf size in blit_buf ~src:buf ~src_pos:(!pos_ref) ~dst:t ~dst_pos:0 size; pos_ref := !pos_ref + size; t let __bin_read_t__ _ ~pos_ref = raise_variant_wrong_type "Bin_prot.Blob.Opaque.t" !pos_ref ;; let bin_writer_t = { Type_class. size = bin_size_t ; write = bin_write_t } let bin_reader_t = { Type_class. read = bin_read_t ; vtag_read = __bin_read_t__ } let bin_t = { Type_class. writer = bin_writer_t ; reader = bin_reader_t } end module Ignored = struct (* The representation of an ignored value is just the size of the value it was created from (i.e., the number of bytes that were ignored from the buffer we were reading -- we exclude the 8 byte size header from which the size was read). *) type t = int let bin_size_t size = Utils.size_header_length + size let bin_read_t buf ~pos_ref = let size = Utils.bin_read_size_header buf ~pos_ref in pos_ref := !pos_ref + size; size let __bin_read_t__ _ ~pos_ref = raise_variant_wrong_type "Bin_prot.Blob.Ignored.t" !pos_ref ;; let bin_reader_t = { Type_class. read = bin_read_t ; vtag_read = __bin_read_t__ } end type 'a t = 'a let bin_size_t bin_size_a a = Utils.size_header_length + bin_size_a a let bin_write_t bin_write_a = fun buf ~pos a -> let start_a = pos + Utils.size_header_length in let end_a = bin_write_a buf ~pos:start_a a in let size = end_a - start_a in let written = Utils.bin_write_size_header buf ~pos size in assert (written = start_a); end_a let bin_read_t bin_read_a = fun buf ~pos_ref -> let expected_size = Utils.bin_read_size_header buf ~pos_ref in let start_a = !pos_ref in let a = bin_read_a buf ~pos_ref in let end_a = !pos_ref in if end_a - start_a <> expected_size then failwith (Printf.sprintf "Bin_prot.Blob.bin_read_t: size (%d) <> expected (%d)" (end_a - start_a) expected_size); a let __bin_read_t__ _ _ ~pos_ref = raise_variant_wrong_type "Bin_prot.Blob.t" !pos_ref ;; let bin_writer_t { Type_class. size = bin_size_a; write = bin_write_a } = { Type_class. size = bin_size_t bin_size_a ; write = bin_write_t bin_write_a } let bin_reader_t { Type_class. read = bin_read_a; vtag_read = __bin_read_a__ } = { Type_class. read = bin_read_t bin_read_a ; vtag_read = __bin_read_t__ __bin_read_a__ } let bin_t { Type_class. writer = bin_writer_a; reader = bin_reader_a } = { Type_class. writer = bin_writer_t bin_writer_a ; reader = bin_reader_t bin_reader_a } let to_opaque t bin_writer = Utils.bin_dump bin_writer t let of_opaque_exn (buffer : Opaque.t) bin_reader = bin_reader.Type_class.read buffer ~pos_ref:(ref 0) bin_prot-113.00.00/lib/blob.mli000066400000000000000000000062651256461074100160360ustar00rootroot00000000000000open Common (** ['a Blob.t] is type-equivalent to ['a], but has different bin-prot serializers that prefix the representation with the size of ['a]. To understand where this is useful, imagine we have an event type where many applications look at some parts of an event, but not all applications need to deal with all parts of an event. We might define: {[ type 'a event = { time : Time.t ; source : string ; details : 'a } with bin_io ]} Applications that need to understand all the details of an event could use: {[type concrete_event = Details.t Blob.t event with bin_io]} An application that filters events to downsteam consumers based on just [source] or [time] (but doesn't need to parse [details]) may use: {[type opaque_event = Blob.Opaque.t event with bin_io]} This has two advantages: - (de)serializing messages is faster because potentially costly (de)serialization of [details] is avoided - the application can be compiled without any knowledge of any conrete [Details.t] type, so it's robust to changes in [Details.t] An application that's happy to throw away [details] may use: {[type ignored_event = Blob.Ignored.t event with bin_read]} Whereas [opaque_event]s roundtrip, [ignored_event]s actually drop the bytes representing [details] when deserializing, and therefore do not roundtrip. *) include Binable.S1 with type 'a t = 'a (** An [Opaque.t] is an arbitrary piece of bin-prot. The bin-prot (de-)serializers simply read/write the data, prefixed with its size. When reading bin-prot data, sometimes you won't care about deserializing a particular piece: perhaps you want to operate on a bin-prot stream, transforming some bits of the stream and passing the others through untouched. In these cases you can deserialize using the bin-prot converters for a type involving [Opaque.t]. This is analogous to reading a sexp file / operating on a sexp stream and using (de-)serialization functions for a type involving [Sexp.t]. *) module Opaque : Binable.S (** An [Ignored.t] is an unusable value with special bin-prot converters. The reader reads the size and drops that much data from the buffer. Writing is not supported, however the size of [t] is kept, so [bin_size_t] is available. This can be used in similar situations to [Opaque.t]. If instead of transforming a bin-prot stream, you are simply consuming it (and not passing it on anywhere), there is no need to remember the bin-prot representation for the bits you're ignoring. E.g. if you wish to extract a subset of information from a bin-prot file, which contains the serialized representation of some type T (or a bunch of Ts in a row, or something similar), you can define a type which is similar to T but has various components replaced with [Ignored.t]. *) module Ignored : sig type t val bin_size_t : t Size.sizer val bin_read_t : t Read.reader val __bin_read_t__ : (int -> t) Read.reader val bin_reader_t : t Type_class.reader end val to_opaque : 'a t -> 'a Type_class.writer -> Opaque.t val of_opaque_exn : Opaque.t -> 'a Type_class.reader -> 'a bin_prot-113.00.00/lib/common.ml000066400000000000000000000143611256461074100162330ustar00rootroot00000000000000(* 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 Poly_rec_write of string exception Empty_type of string let raise_read_error err pos = raise (Read_error (err, pos)) let raise_variant_wrong_type name pos = raise (Read_error (ReadError.Variant_wrong_type name, 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 buf_len buf = Array1.dim buf let assert_pos pos = if pos < 0 then array_bound_error () 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 (* 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 (* Float arrays *) external unsafe_blit_float_array_buf : src_pos : int -> float array -> dst_pos : int -> buf -> len : int -> unit = "bin_prot_blit_float_array_buf_stub" "noalloc" external unsafe_blit_buf_float_array : src_pos : int -> buf -> dst_pos : int -> float array -> len : int -> unit = "bin_prot_blit_buf_float_array_stub" "noalloc" bin_prot-113.00.00/lib/common.mli000066400000000000000000000142401256461074100164000ustar00rootroot00000000000000(** 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 buf_len : buf -> int (** [buf_len buf] returns the length of [buf]. *) val assert_pos : pos -> unit (** [assert_pos pos] @raise Invalid_argument if position [pos] is negative. *) 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 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_variant_wrong_type : string -> pos -> 'a (** [raise_variant_wrong_type name 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]. *) (** {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" external unsafe_blit_float_array_buf : src_pos : int -> float array -> dst_pos : int -> buf -> len : int -> unit = "bin_prot_blit_float_array_buf_stub" "noalloc" external unsafe_blit_buf_float_array : src_pos : int -> buf -> dst_pos : int -> float array -> len : int -> unit = "bin_prot_blit_buf_float_array_stub" "noalloc" bin_prot-113.00.00/lib/config.h000066400000000000000000000000001256461074100160100ustar00rootroot00000000000000bin_prot-113.00.00/lib/float_stubs.c000066400000000000000000000002731256461074100170770ustar00rootroot00000000000000#include #include CAMLprim value bin_prot_get_float_offset(value buf, value pos) { return (value)((char *)Caml_ba_data_val(buf) + Long_val(pos)); } bin_prot-113.00.00/lib/int_codes.mlh000066400000000000000000000002501256461074100170520ustar00rootroot00000000000000(** Int_codes: integer codes used by the binary protocol *) #define CODE_NEG_INT8 '\xff' #define CODE_INT16 '\xfe' #define CODE_INT32 '\xfd' #define CODE_INT64 '\xfc' bin_prot-113.00.00/lib/libbin_prot_stubs.clib000066400000000000000000000001571256461074100207650ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 6a0f42f45cab4e08f4414a4bdeb15008) blit_stubs.o float_stubs.o # OASIS_STOP bin_prot-113.00.00/lib/nat0.ml000066400000000000000000000002701256461074100155770ustar00rootroot00000000000000(* 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-113.00.00/lib/nat0.mli000066400000000000000000000003601256461074100157500ustar00rootroot00000000000000(** 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-113.00.00/lib/read.ml000066400000000000000000000531331256461074100156560ustar00rootroot00000000000000(* Read_ml: reading values from the binary protocol using (mostly) OCaml. *) #include "config.h" #include "int_codes.mlh" open Bigarray open Common 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 external unsafe_get : buf -> int -> char = "%caml_ba_unsafe_ref_1";; external unsafe_get8 : buf -> int -> int = "%caml_ba_unsafe_ref_1";; let unsafe_get8_signed buf pos = let c = unsafe_get8 buf pos in if c >= 128 then c - 256 else c ;; (* We use cpp macros to inline basic functions. We don't rely on OCaml inlining because it doesn't remove the boxing when not necessary. For example, with this code: {[ Int64.to_int (f x y) ]} a temporary int64 will still be allocated, even if [f] is inlined. *) #ifdef JSC_ARCH_SIXTYFOUR let max_int_int64 = Int64.of_int max_int let min_int_int64 = Int64.of_int min_int #define SAFE_INT_OF_INT32(pos, x) (Int32.to_int (x)) #define SAFE_INT_OF_INT64(pos, x) \ (if (x) >= min_int_int64 && (x) <= max_int_int64 then \ Int64.to_int (x) \ else \ raise_read_error ReadError.Int_overflow (pos)) #define SAFE_NATIVEINT_OF_INT64(pos, x) (Int64.to_nativeint (x)) #else let max_int_int32 = Int32.of_int max_int let min_int_int32 = Int32.of_int min_int let max_int_int64 = Int64.of_int max_int let min_int_int64 = Int64.of_int min_int #define SAFE_INT_OF_INT32(pos, x) \ (if (x) >= min_int_int32 && (x) <= max_int_int32 then \ Int32.to_int (x) \ else \ raise_read_error ReadError.Int_overflow (pos)) #define SAFE_INT_OF_INT64(pos, x) \ (if (x) >= min_int_int64 && (x) <= max_int_int64 then \ Int64.to_int (x) \ else \ raise_read_error ReadError.Int_overflow (pos)) #endif #ifdef HAVE_FAST_BA_ACCESS external unsafe_get16 : buf -> int -> int = "%caml_bigstring_get16u";; external unsafe_get32 : buf -> int -> int32 = "%caml_bigstring_get32u";; external unsafe_get64 : buf -> int -> int64 = "%caml_bigstring_get64u";; external bswap16 : int -> int = "%bswap16";; external bswap32 : int32 -> int32 = "%bswap_int32";; external bswap64 : int64 -> int64 = "%bswap_int64";; #ifdef ARCH_BIG_ENDIAN #define UNSAFE_GET16BE_UNSIGNED(buf, pos) (unsafe_get16 (buf) (pos)) #define UNSAFE_GET32BE(buf, pos) (unsafe_get32 (buf) (pos)) #define UNSAFE_GET64BE(buf, pos) (unsafe_get64 (buf) (pos)) #define UNSAFE_GET16LE_UNSIGNED(buf, pos) (bswap16 (unsafe_get16 (buf) (pos))) #define UNSAFE_GET32LE(buf, pos) (bswap32 (unsafe_get32 (buf) (pos))) #define UNSAFE_GET64LE(buf, pos) (bswap64 (unsafe_get64 (buf) (pos))) #else #define UNSAFE_GET16LE_UNSIGNED(buf, pos) (unsafe_get16 (buf) (pos)) #define UNSAFE_GET32LE(buf, pos) (unsafe_get32 (buf) (pos)) #define UNSAFE_GET64LE(buf, pos) (unsafe_get64 (buf) (pos)) #define UNSAFE_GET16BE_UNSIGNED(buf, pos) (bswap16 (unsafe_get16 (buf) (pos))) #define UNSAFE_GET32BE(buf, pos) (bswap32 (unsafe_get32 (buf) (pos))) #define UNSAFE_GET64BE(buf, pos) (bswap64 (unsafe_get64 (buf) (pos))) #endif #define UNSAFE_GET16LE_SIGNED(buf, pos) \ (let x = UNSAFE_GET16LE_UNSIGNED(buf, pos) in \ if x > 32767 then \ x - 65536 \ else \ x) #define UNSAFE_GET16BE_SIGNED(buf, pos) \ (let x = UNSAFE_GET16BE_UNSIGNED(buf, pos) in \ if x > 32767 then \ x - 65536 \ else \ x) #else #define UNSAFE_GET8_AS_INT32(buf, pos) (Int32.of_int (unsafe_get8 (buf) (pos))) #define UNSAFE_GET8_AS_INT64(buf, pos) (Int64.of_int (unsafe_get8 (buf) (pos))) #define UNSAFE_GET16LE_UNSIGNED(buf, pos) \ (let n = unsafe_get8 (buf) (pos) in \ n lor (unsafe_get8 (buf) (pos + 1) lsl 8)) #define UNSAFE_GET16LE_SIGNED(buf, pos) \ (let n = unsafe_get8 (buf) (pos) in \ n lor (unsafe_get8_signed (buf) (pos + 1) lsl 8)) #define UNSAFE_GET32LE(buf, pos) \ (let n = UNSAFE_GET8_AS_INT32(buf, pos) in \ let n = Int32.logor n (Int32.shift_left (UNSAFE_GET8_AS_INT32 (buf, pos + 1)) 8) in \ let n = Int32.logor n (Int32.shift_left (UNSAFE_GET8_AS_INT32 (buf, pos + 2)) 16) in \ Int32.logor n (Int32.shift_left (UNSAFE_GET8_AS_INT32 (buf, pos + 3)) 24)) #define UNSAFE_GET64LE(buf, pos) \ (let n = UNSAFE_GET8_AS_INT64(buf, pos) in \ let n = Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 1)) 8) in \ let n = Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 2)) 16) in \ let n = Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 3)) 24) in \ let n = Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 4)) 32) in \ let n = Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 5)) 40) in \ let n = Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 6)) 48) in \ Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 7)) 56)) #define UNSAFE_GET16BE_UNSIGNED(buf, pos) \ (let n = unsafe_get8 buf (pos + 1) in \ n lor (unsafe_get8 buf pos lsl 8)) #define UNSAFE_GET16BE_SIGNED(buf, pos) \ (let n = unsafe_get8 buf (pos + 1) in \ n lor (unsafe_get8_signed buf pos lsl 8)) #define UNSAFE_GET32BE(buf, pos) \ (let n = UNSAFE_GET8_AS_INT32(buf, pos + 3) in \ let n = Int32.logor n (Int32.shift_left (UNSAFE_GET8_AS_INT32 (buf, pos + 2)) 8) in \ let n = Int32.logor n (Int32.shift_left (UNSAFE_GET8_AS_INT32 (buf, pos + 1)) 16) in \ Int32.logor n (Int32.shift_left (UNSAFE_GET8_AS_INT32 (buf, pos)) 24)) #define UNSAFE_GET64BE(buf, pos) \ (let n = UNSAFE_GET8_AS_INT64(buf, pos + 7) in \ let n = Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 6)) 8) in \ let n = Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 5)) 16) in \ let n = Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 4)) 24) in \ let n = Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 3)) 32) in \ let n = Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 2)) 40) in \ let n = Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos + 1)) 48) in \ Int64.logor n (Int64.shift_left (UNSAFE_GET8_AS_INT64 (buf, pos)) 56)) #endif let bin_read_unit buf ~pos_ref = let pos = safe_get_pos buf pos_ref in assert_pos pos; if unsafe_get buf pos = '\000' then pos_ref := pos + 1 else raise_read_error ReadError.Unit_code pos let bin_read_bool buf ~pos_ref = let pos = safe_get_pos buf pos_ref in assert_pos pos; match unsafe_get buf pos with | '\000' -> pos_ref := pos + 1; false | '\001' -> pos_ref := pos + 1; true | _ -> raise_read_error ReadError.Bool_code pos let safe_bin_read_neg_int8 buf ~pos_ref ~pos = let next = pos + 1 in check_next buf next; let n = unsafe_get8_signed buf pos in if n >= 0 then raise_read_error ReadError.Neg_int8 !pos_ref; pos_ref := next; n let safe_bin_read_int16 buf ~pos_ref ~pos = 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. *) UNSAFE_GET16LE_SIGNED(buf, pos) let safe_bin_read_int32 buf ~pos_ref ~pos = let next = pos + 4 in check_next buf next; pos_ref := next; (* No error possible either. *) UNSAFE_GET32LE(buf, pos) let safe_bin_read_int64 buf ~pos_ref ~pos = let next = pos + 8 in check_next buf next; pos_ref := next; (* No error possible either. *) UNSAFE_GET64LE(buf, pos) let safe_bin_read_int32_as_int buf ~pos_ref ~pos = let next = pos + 4 in check_next buf next; let n = UNSAFE_GET32LE(buf, pos) in let n = SAFE_INT_OF_INT32(!pos_ref, n) in pos_ref := next; n #ifdef JSC_ARCH_SIXTYFOUR let safe_bin_read_int64_as_int buf ~pos_ref ~pos = let next = pos + 8 in check_next buf next; let n = UNSAFE_GET64LE(buf, pos) in let n = SAFE_INT_OF_INT64(!pos_ref, n) in pos_ref := next; n #endif let safe_bin_read_int32_as_int64 buf ~pos_ref ~pos = let next = pos + 4 in check_next buf next; pos_ref := next; let n = UNSAFE_GET32LE(buf, pos) in Int64.of_int32 n let safe_bin_read_int32_as_nativeint buf ~pos_ref ~pos = let next = pos + 4 in check_next buf next; pos_ref := next; let n = UNSAFE_GET32LE(buf, pos) in Nativeint.of_int32 n #ifdef JSC_ARCH_SIXTYFOUR let safe_bin_read_int64_as_nativeint buf ~pos_ref ~pos = let next = pos + 8 in check_next buf next; let n = UNSAFE_GET64LE(buf, pos) in let n = SAFE_NATIVEINT_OF_INT64(pos, n) in pos_ref := next; n #endif let safe_bin_read_nat0_16 buf ~pos_ref ~pos = let next = pos + 2 in check_next buf next; pos_ref := next; Nat0.unsafe_of_int (UNSAFE_GET16LE_UNSIGNED(buf, pos)) #ifdef JSC_ARCH_SIXTYFOUR let safe_bin_read_nat0_32 buf ~pos_ref ~pos = let next = pos + 4 in check_next buf next; pos_ref := next; let n = Int32.to_int (UNSAFE_GET32LE(buf, pos)) in if n >= 0 then Nat0.unsafe_of_int n else (* Erase the upper bits that were set to 1 during the int32 -> int conversion. *) Nat0.unsafe_of_int (n land 0xffff_ffff) let safe_bin_read_nat0_64 buf ~pos_ref ~pos = let next = pos + 8 in check_next buf next; let n = UNSAFE_GET64LE(buf, pos) in if n >= 0L && n <= max_int_int64 then begin let n = Nat0.unsafe_of_int (Int64.to_int n) in pos_ref := next; n end else raise_read_error ReadError.Nat0_overflow !pos_ref #else let safe_bin_read_nat0_32 buf ~pos_ref ~pos = let next = pos + 4 in check_next buf next; let n = UNSAFE_GET32LE(buf, pos) in if n >= 0l && n <= max_int_int32 then begin let n = Nat0.unsafe_of_int (Int32.to_int n) in pos_ref := next; n end else raise_read_error ReadError.Nat0_overflow !pos_ref #endif let bin_read_nat0 buf ~pos_ref = let pos = safe_get_pos buf pos_ref in assert_pos pos; match unsafe_get buf pos with | '\x00'..'\x7f' as ch -> pos_ref := pos + 1; Nat0.unsafe_of_int (Char.code ch) | CODE_INT16 -> safe_bin_read_nat0_16 buf ~pos_ref ~pos:(pos + 1) | CODE_INT32 -> safe_bin_read_nat0_32 buf ~pos_ref ~pos:(pos + 1) #ifdef JSC_ARCH_SIXTYFOUR | CODE_INT64 -> safe_bin_read_nat0_64 buf ~pos_ref ~pos:(pos + 1) #endif | _ -> 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 ~pos_ref = let pos = safe_get_pos buf pos_ref in assert_pos pos; pos_ref := pos + 1; unsafe_get buf pos let bin_read_int buf ~pos_ref = let pos = safe_get_pos buf pos_ref in assert_pos pos; match unsafe_get buf pos with | '\x00'..'\x7f' as ch -> pos_ref := pos + 1; Char.code ch | CODE_NEG_INT8 -> safe_bin_read_neg_int8 buf ~pos_ref ~pos:(pos + 1) | CODE_INT16 -> safe_bin_read_int16 buf ~pos_ref ~pos:(pos + 1) | CODE_INT32 -> safe_bin_read_int32_as_int buf ~pos_ref ~pos:(pos + 1) #ifdef JSC_ARCH_SIXTYFOUR | CODE_INT64 -> safe_bin_read_int64_as_int buf ~pos_ref ~pos:(pos + 1) #endif | _ -> raise_read_error ReadError.Int_code pos ;; #ifdef JSC_ARCH_SIXTYFOUR (* The C stubs returns the address of buf.{pos} as a float array. This is a hack to trick OCaml to read the float at this address. This way it can unbox when [bin_read_float] is inlined. *) external get_float_offset : buf -> pos -> float array = "bin_prot_get_float_offset" "noalloc" #endif let bin_read_float buf ~pos_ref = let pos = safe_get_pos buf pos_ref in assert_pos pos; let next = pos + 8 in check_next buf next; pos_ref := next; #ifdef JSC_ARCH_SIXTYFOUR (* We must use the unsafe function to prevent OCaml from checking the length: the float array returned by [get_float_offset] has no header! *) Array.unsafe_get (get_float_offset buf pos) 0 #else (* No hack in 32bit. (required for Javascript support) *) Int64.float_of_bits (UNSAFE_GET64LE(buf, pos)) #endif ;; let bin_read_int32 buf ~pos_ref = let pos = safe_get_pos buf pos_ref in assert_pos pos; match unsafe_get buf pos with | '\x00'..'\x7f' as ch -> pos_ref := pos + 1; Int32.of_int (Char.code ch) | CODE_NEG_INT8 -> Int32.of_int (safe_bin_read_neg_int8 buf ~pos_ref ~pos:(pos + 1)) | CODE_INT16 -> Int32.of_int (safe_bin_read_int16 buf ~pos_ref ~pos:(pos + 1)) | CODE_INT32 -> safe_bin_read_int32 buf ~pos_ref ~pos:(pos + 1) | _ -> raise_read_error ReadError.Int32_code pos ;; let bin_read_int64 buf ~pos_ref = let pos = safe_get_pos buf pos_ref in assert_pos pos; match unsafe_get buf pos with | '\x00'..'\x7f' as ch -> pos_ref := pos + 1; Int64.of_int (Char.code ch) | CODE_NEG_INT8 -> Int64.of_int (safe_bin_read_neg_int8 buf ~pos_ref ~pos:(pos + 1)) | CODE_INT16 -> Int64.of_int (safe_bin_read_int16 buf ~pos_ref ~pos:(pos + 1)) | CODE_INT32 -> safe_bin_read_int32_as_int64 buf ~pos_ref ~pos:(pos + 1) | CODE_INT64 -> safe_bin_read_int64 buf ~pos_ref ~pos:(pos + 1) | _ -> raise_read_error ReadError.Int64_code pos ;; let bin_read_nativeint buf ~pos_ref = let pos = safe_get_pos buf pos_ref in assert_pos pos; match unsafe_get buf pos with | '\x00'..'\x7f' as ch -> pos_ref := pos + 1; Nativeint.of_int (Char.code ch) | CODE_NEG_INT8 -> Nativeint.of_int (safe_bin_read_neg_int8 buf ~pos_ref ~pos:(pos + 1)) | CODE_INT16 -> Nativeint.of_int (safe_bin_read_int16 buf ~pos_ref ~pos:(pos + 1)) | CODE_INT32 -> safe_bin_read_int32_as_nativeint buf ~pos_ref ~pos:(pos + 1) #ifdef JSC_ARCH_SIXTYFOUR | CODE_INT64 -> safe_bin_read_int64_as_nativeint buf ~pos_ref ~pos:(pos + 1) #endif | _ -> 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 assert_pos pos; match unsafe_get 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 JSC_ARCH_SIXTYFOUR let dummy_float_buf = create_buf 8 let () = ignore (Write.bin_write_float dummy_float_buf ~pos:0 3.1) let max_array_length_2 = Sys.max_array_length / 2 #endif let bin_read_float_array buf ~pos_ref = let pos = !pos_ref in let len = (bin_read_nat0 buf ~pos_ref :> int) in #ifdef JSC_ARCH_SIXTYFOUR if len > Sys.max_array_length then raise_read_error ReadError.Array_too_long pos; #else if len > max_array_length_2 then raise_read_error ReadError.Array_too_long pos; #endif let size = len * 8 in let pos = !pos_ref in let next = pos + size in check_next buf next; let arr = Array.make_float len in unsafe_blit_buf_float_array buf arr ~src_pos:pos ~dst_pos:0 ~len; pos_ref := next; arr ;; let bin_read_array (type a) bin_read_el buf ~pos_ref = if (Obj.magic (bin_read_el : a reader) : float reader) == bin_read_float then (Obj.magic (bin_read_float_array buf ~pos_ref : float array) : a array) else let start_pos = !pos_ref in let len = (bin_read_nat0 buf ~pos_ref :> int) in if len = 0 then [||] else begin #ifdef JSC_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 end 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 buf_of_vec32 : vec32 -> buf = "%identity" external buf_of_vec64 : vec64 -> buf = "%identity" external buf_of_mat32 : mat32 -> buf = "%identity" external buf_of_mat64 : mat64 -> buf = "%identity" let bin_read_float32_vec buf ~pos_ref = let len = (bin_read_nat0 buf ~pos_ref :> int) in let size = len * 4 in let pos = !pos_ref in let next = pos + size in check_next buf next; let vec = Array1.create float32 fortran_layout len in unsafe_blit_buf ~src:buf ~src_pos:pos ~dst:(buf_of_vec32 vec) ~dst_pos:0 ~len:size; pos_ref := next; vec ;; let bin_read_float64_vec buf ~pos_ref = let len = (bin_read_nat0 buf ~pos_ref :> int) in let size = len * 8 in let pos = !pos_ref in let next = pos + size in check_next buf next; let vec = Array1.create float64 fortran_layout len in unsafe_blit_buf ~src:buf ~src_pos:pos ~dst:(buf_of_vec64 vec) ~dst_pos:0 ~len:size; pos_ref := next; vec ;; let bin_read_vec = bin_read_float64_vec let bin_read_float32_mat buf ~pos_ref = let len1 = (bin_read_nat0 buf ~pos_ref :> int) in let len2 = (bin_read_nat0 buf ~pos_ref :> int) in let size = len1 * len2 * 4 in let pos = !pos_ref in let next = pos + size in check_next buf next; let mat = Array2.create float32 fortran_layout len1 len2 in unsafe_blit_buf ~src:buf ~src_pos:pos ~dst:(buf_of_mat32 mat) ~dst_pos:0 ~len:size; pos_ref := next; mat ;; let bin_read_float64_mat buf ~pos_ref = let len1 = (bin_read_nat0 buf ~pos_ref :> int) in let len2 = (bin_read_nat0 buf ~pos_ref :> int) in let size = len1 * len2 * 8 in let pos = !pos_ref in let next = pos + size in check_next buf next; let mat = Array2.create float64 fortran_layout len1 len2 in unsafe_blit_buf ~src:buf ~src_pos:pos ~dst:(buf_of_mat64 mat) ~dst_pos:0 ~len:size; pos_ref := next; mat ;; let bin_read_mat = bin_read_float64_mat let bin_read_bigstring buf ~pos_ref = let len = (bin_read_nat0 buf ~pos_ref :> int) in let pos = !pos_ref in let next = pos + len in check_next buf next; let str = create_buf len in unsafe_blit_buf ~src:buf ~src_pos:pos ~dst:str ~dst_pos:0 ~len; pos_ref := next; str ;; let bin_read_variant_int buf ~pos_ref = let pos = !pos_ref in assert_pos pos; let next = pos + 4 in check_next buf next; let n = UNSAFE_GET32LE(buf, pos) in (* [n] must contain an integer already encoded, i.e. [n = 2 * k + 1]. *) if Int32.logand n 1l = 0l then raise (Read_error (ReadError.Variant_tag, pos)) else begin (* We shift it by one bit to the right se we get back [2 * k + 1] in the end. *) pos_ref := next; Int32.to_int (Int32.shift_right n 1) end ;; let bin_read_int_8bit buf ~pos_ref = let pos = safe_get_pos buf pos_ref in assert_pos pos; pos_ref := pos + 1; unsafe_get8 buf pos ;; let bin_read_int_16bit buf ~pos_ref = let pos = !pos_ref in assert_pos pos; let next = pos + 2 in check_next buf next; pos_ref := next; UNSAFE_GET16LE_UNSIGNED(buf, pos) let bin_read_int_32bit buf ~pos_ref = let pos = !pos_ref in assert_pos pos; let next = pos + 4 in check_next buf next; pos_ref := next; let n = UNSAFE_GET32LE(buf, pos) in SAFE_INT_OF_INT32(pos, n) let bin_read_int_64bit buf ~pos_ref = let pos = !pos_ref in assert_pos pos; let next = pos + 8 in check_next buf next; pos_ref := next; let n = UNSAFE_GET64LE(buf, pos) in SAFE_INT_OF_INT64(pos, n) let bin_read_int64_bits buf ~pos_ref = let pos = !pos_ref in assert_pos pos; let next = pos + 8 in check_next buf next; pos_ref := next; UNSAFE_GET64LE(buf, pos) let bin_read_network16_int buf ~pos_ref = let pos = !pos_ref in assert_pos pos; let next = pos + 2 in check_next buf next; pos_ref := next; UNSAFE_GET16BE_UNSIGNED(buf, pos) let bin_read_network32_int buf ~pos_ref = let pos = !pos_ref in assert_pos pos; let next = pos + 4 in check_next buf next; pos_ref := next; let n = UNSAFE_GET32BE(buf, pos) in SAFE_INT_OF_INT32(pos, n) let bin_read_network32_int32 buf ~pos_ref = let pos = !pos_ref in assert_pos pos; let next = pos + 4 in check_next buf next; pos_ref := next; UNSAFE_GET32BE(buf, pos) let bin_read_network64_int buf ~pos_ref = let pos = !pos_ref in assert_pos pos; let next = pos + 8 in check_next buf next; pos_ref := next; let n = UNSAFE_GET64BE(buf, pos) in SAFE_INT_OF_INT64(pos, n) let bin_read_network64_int64 buf ~pos_ref = let pos = !pos_ref in assert_pos pos; let next = pos + 8 in check_next buf next; pos_ref := next; UNSAFE_GET64BE(buf, pos) bin_prot-113.00.00/lib/read.mli000066400000000000000000000037301256461074100160250ustar00rootroot00000000000000(** 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_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-113.00.00/lib/size.ml000066400000000000000000000116271256461074100157170ustar00rootroot00000000000000(* Size: compute size of values in the binary protocol. *) #include "config.h" 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 JSC_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 JSC_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 JSC_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 f = (* If we just ignore the argument the compiler will still require it to exist and be boxed. This means that if for instance we call this for a field of a float record, the compiler will allocate the float for nothing. With this line the compiler really ignores the float. *) ignore (truncate f); 8 ;; #ifdef JSC_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 JSC_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 JSC_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_float_array ar = let len = Array.length ar in bin_size_len len + 8 * len 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 (type a) bin_size_el ar = if (Obj.magic (bin_size_el : a sizer) : float sizer) == bin_size_float then bin_size_float_array (Obj.magic (ar : a array) : float array) else 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_variant_int _ = 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-113.00.00/lib/size.mli000066400000000000000000000033471256461074100160700ustar00rootroot00000000000000(** 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_int : int 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-113.00.00/lib/std.ml000066400000000000000000000200421256461074100155260ustar00rootroot00000000000000(** 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 = Write.bin_write_unit let bin_reader_unit = Type_class.bin_reader_unit let bin_read_unit = Read.bin_read_unit let __bin_read_unit__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "unit" !pos_ref let bin_bool = Type_class.bin_bool let bin_writer_bool = Type_class.bin_writer_bool let bin_write_bool = Write.bin_write_bool let bin_reader_bool = Type_class.bin_reader_bool let bin_read_bool = Read.bin_read_bool let __bin_read_bool__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "bool" !pos_ref let bin_string = Type_class.bin_string let bin_writer_string = Type_class.bin_writer_string let bin_write_string = Write.bin_write_string let bin_reader_string = Type_class.bin_reader_string let bin_read_string = Read.bin_read_string let __bin_read_string__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "string" !pos_ref let bin_char = Type_class.bin_char let bin_writer_char = Type_class.bin_writer_char let bin_write_char = Write.bin_write_char let bin_reader_char = Type_class.bin_reader_char let bin_read_char = Read.bin_read_char let __bin_read_char__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "char" !pos_ref let bin_int = Type_class.bin_int let bin_writer_int = Type_class.bin_writer_int let bin_write_int = Write.bin_write_int let bin_reader_int = Type_class.bin_reader_int let bin_read_int = Read.bin_read_int let __bin_read_int__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "int" !pos_ref let bin_float = Type_class.bin_float let bin_writer_float = Type_class.bin_writer_float let bin_write_float = Write.bin_write_float let bin_reader_float = Type_class.bin_reader_float let bin_read_float = Read.bin_read_float let __bin_read_float__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "float" !pos_ref type float_array = float array let bin_float_array = Type_class.bin_float_array let bin_writer_float_array = Type_class.bin_writer_float_array let bin_write_float_array = Write.bin_write_float_array let bin_reader_float_array = Type_class.bin_reader_float_array let bin_read_float_array = Read.bin_read_float_array let __bin_read_float_array__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "float_array" !pos_ref let bin_int32 = Type_class.bin_int32 let bin_writer_int32 = Type_class.bin_writer_int32 let bin_write_int32 = Write.bin_write_int32 let bin_reader_int32 = Type_class.bin_reader_int32 let bin_read_int32 = Read.bin_read_int32 let __bin_read_int32__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "int32" !pos_ref let bin_int64 = Type_class.bin_int64 let bin_writer_int64 = Type_class.bin_writer_int64 let bin_write_int64 = Write.bin_write_int64 let bin_reader_int64 = Type_class.bin_reader_int64 let bin_read_int64 = Read.bin_read_int64 let __bin_read_int64__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "int64" !pos_ref let bin_nativeint = Type_class.bin_nativeint let bin_writer_nativeint = Type_class.bin_writer_nativeint let bin_write_nativeint = Write.bin_write_nativeint let bin_reader_nativeint = Type_class.bin_reader_nativeint let bin_read_nativeint = Read.bin_read_nativeint let __bin_read_nativeint__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "nativeint" !pos_ref let bin_ref = Type_class.bin_ref let bin_writer_ref = Type_class.bin_writer_ref let bin_write_ref = Write.bin_write_ref let bin_reader_ref = Type_class.bin_reader_ref let bin_read_ref = Read.bin_read_ref let __bin_read_ref__ _f _buf ~pos_ref _vint = Common.raise_variant_wrong_type "ref" !pos_ref let bin_lazy_t = Type_class.bin_lazy let bin_writer_lazy_t = Type_class.bin_writer_lazy let bin_write_lazy_t = Write.bin_write_lazy let bin_reader_lazy_t = Type_class.bin_reader_lazy let bin_read_lazy_t = Read.bin_read_lazy let __bin_read_lazy_t__ _f _buf ~pos_ref _vint = Common.raise_variant_wrong_type "lazy" !pos_ref let bin_lazy = Type_class.bin_lazy let bin_writer_lazy = Type_class.bin_writer_lazy let bin_write_lazy = Write.bin_write_lazy let bin_reader_lazy = Type_class.bin_reader_lazy let bin_read_lazy = Read.bin_read_lazy let __bin_read_lazy__ _f _buf ~pos_ref _vint = Common.raise_variant_wrong_type "lazy" !pos_ref let bin_option = Type_class.bin_option let bin_writer_option = Type_class.bin_writer_option let bin_write_option = Write.bin_write_option let bin_reader_option = Type_class.bin_reader_option let bin_read_option = Read.bin_read_option let __bin_read_option__ _f _buf ~pos_ref _vint = Common.raise_variant_wrong_type "option" !pos_ref let bin_list = Type_class.bin_list let bin_writer_list = Type_class.bin_writer_list let bin_write_list = Write.bin_write_list let bin_reader_list = Type_class.bin_reader_list let bin_read_list = Read.bin_read_list let __bin_read_list__ _f _buf ~pos_ref _vint = Common.raise_variant_wrong_type "list" !pos_ref let bin_array = Type_class.bin_array let bin_writer_array = Type_class.bin_writer_array let bin_write_array = Write.bin_write_array let bin_reader_array = Type_class.bin_reader_array let bin_read_array = Read.bin_read_array let __bin_read_array__ _f _buf ~pos_ref _vint = Common.raise_variant_wrong_type "array" !pos_ref let bin_hashtbl = Type_class.bin_hashtbl let bin_writer_hashtbl = Type_class.bin_writer_hashtbl let bin_write_hashtbl = Write.bin_write_hashtbl let bin_reader_hashtbl = Type_class.bin_reader_hashtbl let bin_read_hashtbl = Read.bin_read_hashtbl let __bin_read_hashtbl__ _f _g _buf ~pos_ref _vint = Common.raise_variant_wrong_type "hashtbl" !pos_ref let bin_bigstring = Type_class.bin_bigstring let bin_writer_bigstring = Type_class.bin_writer_bigstring let bin_write_bigstring = Write.bin_write_bigstring let bin_reader_bigstring = Type_class.bin_reader_bigstring let bin_read_bigstring = Read.bin_read_bigstring let __bin_read_bigstring__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "bigstring" !pos_ref let bin_mat = Type_class.bin_mat let bin_writer_mat = Type_class.bin_writer_mat let bin_write_mat = Write.bin_write_mat let bin_reader_mat = Type_class.bin_reader_mat let bin_read_mat = Read.bin_read_mat let __bin_read_mat__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "mat" !pos_ref 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 = Write.bin_write_float32_mat let bin_reader_float32_mat = Type_class.bin_reader_float32_mat let bin_read_float32_mat = Read.bin_read_float32_mat let __bin_read_float32_mat__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "float32_mat" !pos_ref 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 = Write.bin_write_float64_mat let bin_reader_float64_mat = Type_class.bin_reader_float64_mat let bin_read_float64_mat = Read.bin_read_float64_mat let __bin_read_float64_mat__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "float64_mat" !pos_ref let bin_vec = Type_class.bin_vec let bin_writer_vec = Type_class.bin_writer_vec let bin_write_vec = Write.bin_write_vec let bin_reader_vec = Type_class.bin_reader_vec let bin_read_vec = Read.bin_read_vec let __bin_read_vec__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "vec" !pos_ref 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 = Write.bin_write_float32_vec let bin_reader_float32_vec = Type_class.bin_reader_float32_vec let bin_read_float32_vec = Read.bin_read_float32_vec let __bin_read_float32_vec__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "float32_vec" !pos_ref 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 = Write.bin_write_float64_vec let bin_reader_float64_vec = Type_class.bin_reader_float64_vec let bin_read_float64_vec = Read.bin_read_float64_vec let __bin_read_float64_vec__ _buf ~pos_ref _vint = Common.raise_variant_wrong_type "float64_vec" !pos_ref bin_prot-113.00.00/lib/type_class.ml000066400000000000000000000117031256461074100171060ustar00rootroot00000000000000(* Tp_class: sizers, writers, and readers in records *) type 'a writer = { size : 'a Size.sizer; write : 'a Write.writer; } type 'a reader = { read : 'a Read.reader; vtag_read : (int -> 'a) Read.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 let variant_wrong_type name _buf ~pos_ref _x = Common.raise_variant_wrong_type name !pos_ref ;; #define MK_BASE(NAME) \ let bin_writer_##NAME = \ { \ size = Size.bin_size_##NAME; \ write = Write.bin_write_##NAME; \ } \ let bin_reader_##NAME = \ { \ read = Read.bin_read_##NAME; \ vtag_read = 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.bin_write_##NAME bin_writer_el.write buf ~pos v); \ } #define MK_BASE1(NAME) \ MK_WRITER_BASE1(NAME) \ let bin_reader_##NAME bin_reader_el = \ { \ read = (fun buf ~pos_ref -> \ Read.bin_read_##NAME bin_reader_el.read buf ~pos_ref); \ vtag_read = 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.bin_write_##NAME \ bin_writer_el1.write bin_writer_el2.write buf ~pos v); \ } \ let bin_reader_##NAME bin_reader_el1 bin_reader_el2 = \ { \ read = (fun buf ~pos_ref -> \ Read.bin_read_##NAME \ bin_reader_el1.read bin_reader_el2.read buf ~pos_ref); \ vtag_read = 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.bin_write_##NAME \ bin_writer_el1.write bin_writer_el2.write \ bin_writer_el3.write buf ~pos v); \ } \ let bin_reader_##NAME bin_reader_el1 bin_reader_el2 bin_reader_el3 = \ { \ read = (fun buf ~pos_ref -> \ Read.bin_read_##NAME \ bin_reader_el1.read bin_reader_el2.read \ bin_reader_el3.read buf ~pos_ref); \ vtag_read = 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_int) 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)); } let cnv_reader cnv tp_class = { read = (fun buf ~pos_ref -> cnv (tp_class.read buf ~pos_ref)); vtag_read = (fun buf ~pos_ref vtag -> cnv (tp_class.vtag_read buf ~pos_ref 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-113.00.00/lib/type_class.mli000066400000000000000000000061261256461074100172620ustar00rootroot00000000000000(** Sizers, writers, and readers in records *) open Common type 'a writer = { size : 'a Size.sizer; write : 'a Write.writer; } type 'a reader = { read : 'a Read.reader; vtag_read : (int -> 'a) Read.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_int : int writer val bin_reader_variant_int : int reader val bin_variant_int : int 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-113.00.00/lib/utils.ml000066400000000000000000000305201256461074100160760ustar00rootroot00000000000000(* Utils: utility functions for user convenience *) open Common open Size open Type_class let size_header_length = 8 let bin_write_size_header = Write.bin_write_int_64bit let bin_read_size_header = Read.bin_read_int_64bit 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 + size_header_length in let buf = create_buf tot_len in let pos = bin_write_size_header buf ~pos:0 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 size_header_length in read buf ~pos:0 ~len:size_header_length; let pos_ref = ref 0 in let len = bin_read_size_header buf ~pos_ref in 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 > size_header_length 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_read_t buf ~pos_ref = S.of_binable (B.bin_read_t buf ~pos_ref) let __bin_read_t__ buf ~pos_ref n = S.of_binable (B.__bin_read_t__ buf ~pos_ref n) let bin_writer_t = { size = bin_size_t; write = bin_write_t; } let bin_reader_t = { read = bin_read_t; 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_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 buf ~pos_ref n = S.of_binable (B.__bin_read_t__ bin_read_el buf ~pos_ref 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.write buf ~pos v); } let bin_reader_t bin_reader = { read = (fun buf ~pos_ref -> bin_read_t bin_reader.read buf ~pos_ref); vtag_read = (fun _buf ~pos_ref _n -> raise_variant_wrong_type "Bin_prot.Utils.Make_binable1.bin_reader_t" !pos_ref); } 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_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 buf ~pos_ref n = S.of_binable (B.__bin_read_t__ bin_read_el1 bin_read_el2 buf ~pos_ref 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.write bin_writer2.write buf ~pos v); } let bin_reader_t bin_reader1 bin_reader2 = { read = (fun buf ~pos_ref -> bin_read_t bin_reader1.read bin_reader2.read buf ~pos_ref); vtag_read = (fun _buf ~pos_ref _n -> raise_variant_wrong_type "Bin_prot.Utils.Make_binable2.bin_reader_t" !pos_ref); } 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 Write.writer val bin_read_el : el Read.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 buf ~pos t = let len = length t in let plen = Nat0.unsafe_of_int len in let pos_ref = ref (Write.bin_write_nat0 buf ~pos plen) in let cnt_ref = ref 0 in iter t ~f:(fun el -> pos_ref := bin_write_el buf ~pos:!pos_ref el; incr cnt_ref); if !cnt_ref = len then !pos_ref else raise_concurrent_modification "bin_write_t" let bin_read_t buf ~pos_ref = let len = (Read.bin_read_nat0 buf ~pos_ref :> int) in let rec loop acc i = if i = len then finish acc else let new_acc = insert acc (bin_read_el buf ~pos_ref) i in loop new_acc (i + 1) in loop (init len) 0 let __bin_read_t__ _buf ~pos_ref _n = raise_variant_wrong_type "t" !pos_ref let bin_writer_t = { size = bin_size_t; write = bin_write_t; } let bin_reader_t = { read = bin_read_t; 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) Write.writer1 val bin_read_el : ('a, 'a el) Read.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 buf ~pos t = let len = length t in let plen = Nat0.unsafe_of_int len in let pos_ref = ref (Write.bin_write_nat0 buf ~pos plen) in let cnt_ref = ref 0 in iter t ~f:(fun el -> pos_ref := bin_write_el bin_write_a buf ~pos:!pos_ref el; incr cnt_ref); if !cnt_ref = len then !pos_ref else raise_concurrent_modification "bin_write_t" let bin_read_t bin_read_a buf ~pos_ref = let len = (Read.bin_read_nat0 buf ~pos_ref :> 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 buf ~pos_ref) i in loop new_acc (i + 1) in loop (init len) 0 let __bin_read_t__ _bin_read_a _buf ~pos_ref _n = raise_variant_wrong_type "t" !pos_ref 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.write buf ~pos v); } let bin_reader_t bin_reader = { read = (fun buf ~pos_ref -> bin_read_t bin_reader.read buf ~pos_ref); vtag_read = (fun buf ~pos_ref _n -> __bin_read_t__ bin_reader.read buf ~pos_ref _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) Write.writer2 val bin_read_el : ('a, 'b, ('a, 'b) el) Read.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 buf ~pos t = let len = length t in let plen = Nat0.unsafe_of_int len in let pos_ref = ref (Write.bin_write_nat0 buf ~pos plen) in let cnt_ref = ref 0 in iter t ~f:(fun el -> pos_ref := bin_write_el bin_write_a bin_write_b buf ~pos:!pos_ref el; incr cnt_ref); if !cnt_ref = len then !pos_ref else raise_concurrent_modification "bin_write_t" let bin_read_t bin_read_a bin_read_b buf ~pos_ref = let len = (Read.bin_read_nat0 buf ~pos_ref :> 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 buf ~pos_ref) 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 _n = raise_variant_wrong_type "t" !pos_ref 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.write bin_writer2.write buf ~pos v); } let bin_reader_t bin_reader1 bin_reader2 = { read = (fun buf ~pos_ref -> bin_read_t bin_reader1.read bin_reader2.read buf ~pos_ref); vtag_read = (fun buf ~pos_ref n -> __bin_read_t__ bin_reader1.read bin_reader2.read buf ~pos_ref 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-113.00.00/lib/utils.mli000066400000000000000000000115261256461074100162540ustar00rootroot00000000000000(** Utility functions for user convenience *) open Common open Type_class val size_header_length : int (** [size_header_length] is the standard number of bytes allocated for the size header in size-prefixed bin-io payloads. This size-prefixed layout is used by the [bin_dump] and [bin_read_stream] functions below, as well as: - Core.Std.Bigstring.{read,write}_bin_prot - Core.Std.Unpack_buffer.unpack_bin_prot - Async.Std.{Reader,Writer}.{read,write}_bin_prot among others. The size prefix is always 8 bytes at present. This is exposed so your program does not have to know this fact too. We do not use a variable length header because we want to know how many bytes to read to get the size without having to peek into the payload. *) val bin_read_size_header : int Read.reader val bin_write_size_header : int Write.writer (** [bin_read_size_header] and [bin_write_size_header] are bin-prot serializers for the size header described above. *) 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 Write.writer val bin_read_el : el Read.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) Write.writer1 val bin_read_el : ('a, 'a el) Read.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) Write.writer2 val bin_read_el : ('a, 'b, ('a, 'b) el) Read.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-113.00.00/lib/write.ml000066400000000000000000000346501256461074100161000ustar00rootroot00000000000000(* Write_ml: writing values to the binary protocol using (mostly) OCaml. *) #include "config.h" #include "int_codes.mlh" open Bigarray 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 external unsafe_set : buf -> int -> char -> unit = "%caml_ba_unsafe_set_1";; external unsafe_set8 : buf -> int -> int -> unit = "%caml_ba_unsafe_set_1";; #ifdef HAVE_FAST_BA_ACCESS external unsafe_set16 : buf -> int -> int -> unit = "%caml_bigstring_set16u";; external unsafe_set32 : buf -> int -> int32 -> unit = "%caml_bigstring_set32u";; external unsafe_set64 : buf -> int -> int64 -> unit = "%caml_bigstring_set64u";; external bswap16 : int -> int = "%bswap16";; external bswap32 : int32 -> int32 = "%bswap_int32";; external bswap64 : int64 -> int64 = "%bswap_int64";; (* See comment in read.ml about why we use macros instead of functions. *) #ifdef ARCH_BIG_ENDIAN #define UNSAFE_SET16BE(buf, pos, x) (unsafe_set16 (buf) (pos) (x)) #define UNSAFE_SET32BE(buf, pos, x) (unsafe_set32 (buf) (pos) (x)) #define UNSAFE_SET64BE(buf, pos, x) (unsafe_set64 (buf) (pos) (x)) #define UNSAFE_SET16LE(buf, pos, x) (unsafe_set16 (buf) (pos) (bswap16 (x))) #define UNSAFE_SET32LE(buf, pos, x) (unsafe_set32 (buf) (pos) (bswap32 (x))) #define UNSAFE_SET64LE(buf, pos, x) (unsafe_set64 (buf) (pos) (bswap64 (x))) #else #define UNSAFE_SET16LE(buf, pos, x) (unsafe_set16 (buf) (pos) (x)) #define UNSAFE_SET32LE(buf, pos, x) (unsafe_set32 (buf) (pos) (x)) #define UNSAFE_SET64LE(buf, pos, x) (unsafe_set64 (buf) (pos) (x)) #define UNSAFE_SET16BE(buf, pos, x) (unsafe_set16 (buf) (pos) (bswap16 (x))) #define UNSAFE_SET32BE(buf, pos, x) (unsafe_set32 (buf) (pos) (bswap32 (x))) #define UNSAFE_SET64BE(buf, pos, x) (unsafe_set64 (buf) (pos) (bswap64 (x))) #endif #else #define UNSAFE_SET8_FROM_INT32(buf, pos, x) (unsafe_set8 (buf) (pos) (Int32.to_int (x))) #define UNSAFE_SET8_FROM_INT64(buf, pos, x) (unsafe_set8 (buf) (pos) (Int64.to_int (x))) #define UNSAFE_SET16LE(buf, pos, x) \ (let _pos = pos and _x = x in \ unsafe_set8 buf _pos _x; \ unsafe_set8 buf (_pos + 1) (_x asr 8)) #define UNSAFE_SET32LE(buf, pos, x) \ (let _pos = pos and _x = x in \ UNSAFE_SET8_FROM_INT32 (buf, _pos, _x); \ UNSAFE_SET8_FROM_INT32 (buf, _pos + 1, Int32.shift_right _x 8); \ UNSAFE_SET8_FROM_INT32 (buf, _pos + 2, Int32.shift_right _x 16); \ UNSAFE_SET8_FROM_INT32 (buf, _pos + 3, Int32.shift_right _x 24)) #define UNSAFE_SET64LE(buf, pos, x) \ (let _pos = pos and _x = x in \ UNSAFE_SET8_FROM_INT64 (buf, _pos, _x); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 1, Int64.shift_right _x 8); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 2, Int64.shift_right _x 16); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 3, Int64.shift_right _x 24); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 4, Int64.shift_right _x 32); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 5, Int64.shift_right _x 40); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 6, Int64.shift_right _x 48); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 7, Int64.shift_right _x 56)) #define UNSAFE_SET16BE(buf, pos, x) \ (let _pos = pos and _x = x in \ unsafe_set8 buf (_pos + 1) _x; \ unsafe_set8 buf _pos (_x lsr 8)) #define UNSAFE_SET32BE(buf, pos, x) \ (let _pos = pos and _x = x in \ UNSAFE_SET8_FROM_INT32 (buf, _pos + 3, _x); \ UNSAFE_SET8_FROM_INT32 (buf, _pos + 2, Int32.shift_right _x 8); \ UNSAFE_SET8_FROM_INT32 (buf, _pos + 1, Int32.shift_right _x 16); \ UNSAFE_SET8_FROM_INT32 (buf, _pos, Int32.shift_right _x 24)) #define UNSAFE_SET64BE(buf, pos, x) \ (let _pos = pos and _x = x in \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 7, _x); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 6, Int64.shift_right _x 8); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 5, Int64.shift_right _x 16); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 4, Int64.shift_right _x 24); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 3, Int64.shift_right _x 32); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 2, Int64.shift_right _x 40); \ UNSAFE_SET8_FROM_INT64 (buf, _pos + 1, Int64.shift_right _x 48); \ UNSAFE_SET8_FROM_INT64 (buf, _pos, Int64.shift_right _x 56)) #endif let bin_write_unit buf ~pos () = assert_pos pos; check_pos buf pos; unsafe_set buf pos '\000'; pos + 1 let bin_write_bool buf ~pos b = assert_pos pos; check_pos buf pos; unsafe_set buf pos (if b then '\001' else '\000'); pos + 1 #define ALL_BIN_WRITE_SMALL_INT(buf, pos, n) \ (check_pos buf pos; \ unsafe_set8 buf pos (n); \ pos + 1) #define ALL_BIN_WRITE_NEG_INT8(buf, pos, n) \ (let next = pos + 2 in \ check_next buf next; \ unsafe_set buf pos CODE_NEG_INT8; \ unsafe_set8 buf (pos + 1) (n); \ next) #define ALL_BIN_WRITE_INT16(buf, pos, n) \ (let next = pos + 3 in \ check_next buf next; \ unsafe_set buf pos CODE_INT16; \ UNSAFE_SET16LE(buf, pos + 1, n); \ next) #define ALL_BIN_WRITE_INT32(buf, pos, n) \ (let next = pos + 5 in \ check_next buf next; \ unsafe_set buf pos CODE_INT32; \ UNSAFE_SET32LE(buf, pos + 1, n); \ next) #define ALL_BIN_WRITE_INT64(buf, pos, n) \ (let next = pos + 9 in \ check_next buf next; \ unsafe_set buf pos CODE_INT64; \ UNSAFE_SET64LE(buf, pos + 1, n); \ next) let bin_write_char buf ~pos c = assert_pos pos; check_pos buf pos; unsafe_set buf pos c; pos + 1 let bin_write_int buf ~pos n = assert_pos pos; if n >= 0 then begin if n < 0x00000080 then ALL_BIN_WRITE_SMALL_INT(buf, pos, n) else if n < 0x00008000 then ALL_BIN_WRITE_INT16(buf, pos, n) else #ifdef JSC_ARCH_SIXTYFOUR if n >= 0x80000000 then ALL_BIN_WRITE_INT64(buf, pos, Int64.of_int n) else #endif ALL_BIN_WRITE_INT32(buf, pos, Int32.of_int n) end else begin if n >= -0x00000080 then ALL_BIN_WRITE_NEG_INT8(buf, pos, n) else if n >= -0x00008000 then ALL_BIN_WRITE_INT16(buf, pos, n) else #ifdef JSC_ARCH_SIXTYFOUR if n < -0x80000000 then ALL_BIN_WRITE_INT64(buf, pos, Int64.of_int n) else #endif ALL_BIN_WRITE_INT32(buf, pos, Int32.of_int n) end let bin_write_nat0 buf ~pos nat0 = assert_pos pos; 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) else #ifdef JSC_ARCH_SIXTYFOUR if n >= 0x100000000 then ALL_BIN_WRITE_INT64(buf, pos, Int64.of_int n) else #endif ALL_BIN_WRITE_INT32(buf, pos, Int32.of_int 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 #ifdef JSC_ARCH_SIXTYFOUR (* Same trick as in read.ml *) external get_float_offset : buf -> pos -> float array = "bin_prot_get_float_offset" "noalloc" #endif let bin_write_float buf ~pos x = assert_pos pos; let next = pos + 8 in check_next buf next; #ifdef JSC_ARCH_SIXTYFOUR Array.unsafe_set (get_float_offset buf pos) 0 x; #else (* No hack in 32bit. (required for Javascript support) *) UNSAFE_SET64LE(buf, pos, Int64.bits_of_float x); #endif next #ifdef JSC_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 begin assert_pos pos; ALL_BIN_WRITE_INT32(buf, pos, n) end else bin_write_int buf ~pos (Int32.to_int n) #endif let bin_write_int64 buf ~pos n = if n >= 0x80000000L || n < -0x80000000L then begin assert_pos pos; ALL_BIN_WRITE_INT64(buf, pos, n) end else #ifdef JSC_ARCH_SIXTYFOUR bin_write_int buf ~pos (Int64.to_int n) #else if n >= 0x00008000L || n < -0x00008000L then begin assert_pos pos; ALL_BIN_WRITE_INT32(buf, pos, Int64.to_int32 n) end else bin_write_int buf ~pos (Int64.to_int n) #endif let bin_write_nativeint buf ~pos n = #ifdef JSC_ARCH_SIXTYFOUR if n >= 0x80000000n || n < -0x80000000n then begin assert_pos pos; ALL_BIN_WRITE_INT64(buf, pos, Int64.of_nativeint n) end #else if n >= 0x00008000n || n < -0x00008000n then begin assert_pos pos; ALL_BIN_WRITE_INT32(buf, pos, Nativeint.to_int32 n) end #endif else bin_write_int buf ~pos (Nativeint.to_int n) 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_float_array buf ~pos a = let len = Array.length a in let plen = Nat0.unsafe_of_int len in let pos = bin_write_nat0 buf ~pos plen in let size = len * 8 in let next = pos + size in check_next buf next; unsafe_blit_float_array_buf a buf ~src_pos:0 ~dst_pos:pos ~len; next 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 (type a) bin_write_el buf ~pos ar = if (Obj.magic (bin_write_el : a writer) : float writer) == bin_write_float then bin_write_float_array buf ~pos (Obj.magic (ar : a array) : float array) else 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 buf_of_vec32 : vec32 -> buf = "%identity" external buf_of_vec64 : vec64 -> buf = "%identity" external buf_of_mat32 : mat32 -> buf = "%identity" external buf_of_mat64 : mat64 -> buf = "%identity" let bin_write_float32_vec buf ~pos v = let len = Array1.dim v in let plen = Nat0.unsafe_of_int len in let pos = bin_write_nat0 buf ~pos plen in let size = len * 4 in let next = pos + size in check_next buf next; unsafe_blit_buf ~src:(buf_of_vec32 v) ~src_pos:0 ~dst:buf ~dst_pos:pos ~len:size; next let bin_write_float64_vec buf ~pos v = let len = Array1.dim v in let plen = Nat0.unsafe_of_int len in let pos = bin_write_nat0 buf ~pos plen in let size = len * 8 in let next = pos + size in check_next buf next; unsafe_blit_buf ~src:(buf_of_vec64 v) ~src_pos:0 ~dst:buf ~dst_pos:pos ~len:size; next let bin_write_vec = bin_write_float64_vec let bin_write_float32_mat buf ~pos m = let len1 = Array2.dim1 m in let len2 = Array2.dim2 m in let pos = bin_write_nat0 buf ~pos (Nat0.unsafe_of_int len1) in let pos = bin_write_nat0 buf ~pos (Nat0.unsafe_of_int len2) in let size = len1 * len2 * 4 in let next = pos + size in check_next buf next; unsafe_blit_buf ~src:(buf_of_mat32 m) ~src_pos:0 ~dst:buf ~dst_pos:pos ~len:size; next let bin_write_float64_mat buf ~pos m = let len1 = Array2.dim1 m in let len2 = Array2.dim2 m in let pos = bin_write_nat0 buf ~pos (Nat0.unsafe_of_int len1) in let pos = bin_write_nat0 buf ~pos (Nat0.unsafe_of_int len2) in let size = len1 * len2 * 8 in let next = pos + size in check_next buf next; unsafe_blit_buf ~src:(buf_of_mat64 m) ~src_pos:0 ~dst:buf ~dst_pos:pos ~len:size; next let bin_write_mat = bin_write_float64_mat let bin_write_bigstring buf ~pos s = let len = Array1.dim s in let plen = Nat0.unsafe_of_int len in let pos = bin_write_nat0 buf ~pos plen in let next = pos + len in check_next buf next; unsafe_blit_buf ~src:s ~src_pos:0 ~dst:buf ~dst_pos:pos ~len; next let bin_write_variant_int buf ~pos x = assert_pos pos; let next = pos + 4 in check_next buf next; UNSAFE_SET32LE(buf, pos, Int32.logor (Int32.shift_left (Int32.of_int x) 1) 1l); next let bin_write_int_8bit buf ~pos n = assert_pos pos; check_pos buf pos; unsafe_set8 buf pos n; pos + 1 let bin_write_int_16bit buf ~pos n = assert_pos pos; let next = pos + 2 in check_next buf next; UNSAFE_SET16LE(buf, pos, n); next let bin_write_int_32bit buf ~pos n = assert_pos pos; let next = pos + 4 in check_next buf next; UNSAFE_SET32LE(buf, pos, Int32.of_int n); next let bin_write_int_64bit buf ~pos n = assert_pos pos; let next = pos + 8 in check_next buf next; UNSAFE_SET64LE(buf, pos, Int64.of_int n); next let bin_write_int64_bits buf ~pos n = assert_pos pos; let next = pos + 8 in check_next buf next; UNSAFE_SET64LE(buf, pos, n); next let bin_write_network16_int buf ~pos n = assert_pos pos; let next = pos + 2 in check_next buf next; UNSAFE_SET16BE(buf, pos, n); next let bin_write_network32_int buf ~pos n = assert_pos pos; let next = pos + 4 in check_next buf next; UNSAFE_SET32BE(buf, pos, Int32.of_int n); next let bin_write_network32_int32 buf ~pos n = assert_pos pos; let next = pos + 4 in check_next buf next; UNSAFE_SET32BE(buf, pos, n); next let bin_write_network64_int buf ~pos n = assert_pos pos; let next = pos + 8 in check_next buf next; UNSAFE_SET64BE(buf, pos, Int64.of_int n); next let bin_write_network64_int64 buf ~pos n = assert_pos pos; let next = pos + 8 in check_next buf next; UNSAFE_SET64BE(buf, pos, n); next 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-113.00.00/lib/write.mli000066400000000000000000000067441256461074100162540ustar00rootroot00000000000000(** 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_int : int writer (** [bin_write_variant_int] 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-113.00.00/myocamlbuild.ml000066400000000000000000000437641256461074100166670ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: dfffc4acb9fbdd8bf7abad2da466a7cd) *) module OASISGettext = struct (* # 22 "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 (* # 22 "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 # 132 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "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 rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 237 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "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 type conf = { no_automatic_syntax: bool; } (* 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 exec_from_conf exec = let exec = let env_filename = Pathname.basename BaseEnvLight.default_filename in let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in try BaseEnvLight.var_get exec env with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" exec; exec in let fix_win32 str = if Sys.os_type = "Win32" then begin let buff = Buffer.create (String.length str) in (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. *) String.iter (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) str; Buffer.contents buff end else begin str end in fix_win32 exec let split s ch = let buf = Buffer.create 13 in let x = ref [] in let flush () = x := (Buffer.contents buf) :: !x; Buffer.clear buf in String.iter (fun c -> if c = ch then flush () else Buffer.add_char buf c) s; flush (); List.rev !x let split_nl s = split s '\n' let before_space s = try String.before s (String.index s ' ') with Not_found -> s (* ocamlfind command *) let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] (* This lists all supported packages. *) let find_packages () = List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) (* Mock to list available syntaxes. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] let well_known_syntax = [ "camlp4.quotations.o"; "camlp4.quotations.r"; "camlp4.exceptiontracer"; "camlp4.extend"; "camlp4.foldgenerator"; "camlp4.listcomprehension"; "camlp4.locationstripper"; "camlp4.macro"; "camlp4.mapgenerator"; "camlp4.metagenerator"; "camlp4.profiler"; "camlp4.tracer" ] let dispatch conf = function | After_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"; Options.ocamlmklib := ocamlfind & A"ocamlmklib" | After_rules -> (* When one link an OCaml library/binary/package, one should use * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; if not (conf.no_automatic_syntax) then begin (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> let base_args = [A"-package"; A pkg] in (* TODO: consider how to really choose camlp4o or camlp4r. *) let syn_args = [A"-syntax"; A "camlp4o"] in let (args, pargs) = (* Heuristic to identify syntax extensions: whether they end in ".syntax"; some might not. *) if Filename.check_suffix pkg "syntax" || List.mem pkg well_known_syntax then (syn_args @ base_args, syn_args) else (base_args, []) in flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; (* TODO: Check if this is allowed for OCaml < 3.12.1 *) flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; end (find_packages ()); end; (* 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"]); flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); | _ -> () end module MyOCamlbuildBase = struct (* # 22 "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 (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { lib_ocaml: (name * dir list * string 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\n" 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, [], intf_modules -> ocaml_lib nm; let cmis = List.map (fun m -> (String.uncapitalize m) ^ ".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis | nm, dir :: tl, intf_modules -> 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; let cmis = List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] cmis) 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. This holds both for programs and for libraries. *) dep ["link"; "ocaml"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; dep ["compile"; "ocaml"; 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 let rec eval_specs = function | S lst -> S (List.map eval_specs lst) | A str -> A (BaseEnvLight.var_expand str env) | spec -> spec in flag tags & (eval_specs spec)) t.flags | _ -> () let dispatch_default conf t = dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch conf; ] end # 606 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [("bin_prot", ["lib"], []); ("pa_bin_prot", ["syntax"], [])]; lib_c = [("bin_prot", "lib", ["lib/config.h"])]; flags = []; includes = [("test", ["lib"; "syntax"])] } ;; let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; # 623 "myocamlbuild.ml" (* OASIS_STOP *) let dispatch = function | After_rules -> let env = BaseEnvLight.load () in let system = BaseEnvLight.var_get "system" env in let cc = BaseEnvLight.var_get "bytecomp_c_compiler" env in let is_darwin = String.is_prefix "macos" system in let arch_sixtyfour = BaseEnvLight.var_get "arch_sixtyfour" env = "true" in let cpp = cc ^ " -E -xc -undef -w" in let cpp = if arch_sixtyfour then cpp ^ " -DJSC_ARCH_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-113.00.00/setup.ml000066400000000000000000005621461256461074100153460ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 0ce326be565ce0c6027601d63b11e6c3) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 22 "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 (* # 22 "src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type t = { (* TODO: replace this by a proplist. *) 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 fspecs () = (* TODO: don't act on default. *) let ignore_plugins = ref false in ["-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"; "-ignore-plugins", Arg.Set ignore_plugins, s_ " Ignore plugin's field."; "-C", (* TODO: remove this chdir. *) Arg.String (fun str -> Sys.chdir str), s_ "dir Change directory before running."], fun () -> {!default with ignore_plugins = !ignore_plugins} end module OASISString = struct (* # 22 "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 = Buffer.create (String.length s) in String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf end module OASISUtils = struct (* # 22 "src/oasis/OASISUtils.ml" *) open OASISGettext module MapExt = struct module type S = sig include Map.S val add_list: 'a t -> (key * 'a) list -> 'a t val of_list: (key * 'a) list -> 'a t val to_list: 'a t -> (key * 'a) list end module Make (Ord: Map.OrderedType) = struct include Map.Make(Ord) let rec add_list t = function | (k, v) :: tl -> add_list (add k v t) tl | [] -> t let of_list lst = add_list empty lst let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] end end module MapString = MapExt.Make(String) module SetExt = struct module type S = sig include Set.S val add_list: t -> elt list -> t val of_list: elt list -> t val to_list: t -> elt list end module Make (Ord: Set.OrderedType) = struct include Set.Make(Ord) let rec add_list t = function | e :: tl -> add_list (add e t) tl | [] -> t let of_list lst = add_list empty lst let to_list = elements end end module SetString = SetExt.Make(String) 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) module SetStringCsl = SetExt.Make (struct type t = string let compare = compare_csl 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 (* # 22 "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 (* # 78 "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 (* # 22 "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 (* # 22 "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 version_compare_string s1 s2 = version_compare (version_of_string s1) (version_of_string s2) 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 rec comparator_ge v' = let cmp v = version_compare v v' >= 0 in function | VEqual v | VGreaterEqual v | VGreater v -> cmp v | VLesserEqual _ | VLesser _ -> false | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 end module OASISLicense = struct (* # 22 "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 (* # 22 "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 OASISText = struct (* # 22 "src/oasis/OASISText.ml" *) type elt = | Para of string | Verbatim of string | BlankLine type t = elt list end module OASISTypes = struct (* # 22 "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 (* # 115 "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 object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; } 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 | Object of common_section * build_section * object_ | 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 | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; alpha_features: string list; beta_features: string list; 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: OASISText.t 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; disable_oasis_section: unix_filename list; schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISFeatures = struct (* # 22 "src/oasis/OASISFeatures.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISVersion module MapPlugin = Map.Make (struct type t = plugin_kind * name let compare = Pervasives.compare end) module Data = struct type t = { oasis_version: OASISVersion.t; plugin_versions: OASISVersion.t option MapPlugin.t; alpha_features: string list; beta_features: string list; } let create oasis_version alpha_features beta_features = { oasis_version = oasis_version; plugin_versions = MapPlugin.empty; alpha_features = alpha_features; beta_features = beta_features } let of_package pkg = create pkg.OASISTypes.oasis_version pkg.OASISTypes.alpha_features pkg.OASISTypes.beta_features let add_plugin (plugin_kind, plugin_name, plugin_version) t = {t with plugin_versions = MapPlugin.add (plugin_kind, plugin_name) plugin_version t.plugin_versions} let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions let to_string t = Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" (OASISVersion.string_of_version t.oasis_version) (String.concat ", " t.alpha_features) (String.concat ", " t.beta_features) (String.concat ", " (MapPlugin.fold (fun (_, plg) ver_opt acc -> (plg^ (match ver_opt with | Some v -> " "^(OASISVersion.string_of_version v) | None -> "")) :: acc) t.plugin_versions [])) end type origin = | Field of string * string | Section of string | NoOrigin type stage = Alpha | Beta let string_of_stage = function | Alpha -> "alpha" | Beta -> "beta" let field_of_stage = function | Alpha -> "AlphaFeatures" | Beta -> "BetaFeatures" type publication = InDev of stage | SinceVersion of OASISVersion.t type t = { name: string; plugin: all_plugin option; publication: publication; description: unit -> string; } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 let since_version ver_str = SinceVersion (version_of_string ver_str) let alpha = InDev Alpha let beta = InDev Beta let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" t.name (match t.plugin with | None -> "" | Some (_, nm, _) -> nm) (match t.publication with | InDev stage -> string_of_stage stage | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) let data_check t data origin = let no_message = "no message" in let check_feature features stage = let has_feature = List.mem t.name features in if not has_feature then match origin with | Field (fld, where) -> Some (Printf.sprintf (f_ "Field %s in %s is only available when feature %s \ is in field %s.") fld where t.name (field_of_stage stage)) | Section sct -> Some (Printf.sprintf (f_ "Section %s is only available when features %s \ is in field %s.") sct t.name (field_of_stage stage)) | NoOrigin -> Some no_message else None in let version_is_good ~min_version version fmt = let version_is_good = OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in Printf.ksprintf (fun str -> if version_is_good then None else Some str) fmt in match origin, t.plugin, t.publication with | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha | _, _, InDev Beta -> check_feature data.Data.beta_features Beta | Field(fld, where), None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Field %s in %s is only valid since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking \ OASIS changelog.") fld where (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Field(fld, where), Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Field %s in %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") fld where plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Field %s in %s is only valid when the OASIS plugin %s \ is defined.") fld where plugin_name in version_is_good ~min_version plugin_version_current (f_ "Field %s in %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") fld where plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | Section sct, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Section %s is only valid for since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking OASIS \ changelog.") sct (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Section sct, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Section %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") sct plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Section %s is only valid when the OASIS plugin %s \ is defined.") sct plugin_name in version_is_good ~min_version plugin_version_current (f_ "Section %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") sct plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | NoOrigin, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version "%s" no_message | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> raise Not_found in version_is_good ~min_version plugin_version_current "%s" no_message with Not_found -> Some no_message end let data_assert t data origin = match data_check t data origin with | None -> () | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with | None -> true | Some str -> false let package_test t pkg = data_test t (Data.of_package pkg) let create ?plugin name publication description = let () = if Hashtbl.mem all_features name then failwithf "Feature '%s' is already declared." name in let t = { name = name; plugin = plugin; publication = publication; description = description; } in Hashtbl.add all_features name t; t let get_stage name = try (Hashtbl.find all_features name).publication with Not_found -> failwithf (f_ "Feature %s doesn't exist.") name let list () = Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] (* * Real flags. *) let features = create "features_fields" (since_version "0.4") (fun () -> s_ "Enable to experiment not yet official features.") let flag_docs = create "flag_docs" (since_version "0.3") (fun () -> s_ "Building docs require '-docs' flag at configure.") let flag_tests = create "flag_tests" (since_version "0.3") (fun () -> s_ "Running tests require '-tests' flag at configure.") let pack = create "pack" (since_version "0.3") (fun () -> s_ "Allow to create packed library.") let section_object = create "section_object" beta (fun () -> s_ "Implement an object section.") let dynrun_for_release = create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> s_ "It compiles the setup.ml and speed-up actions done with it.") let disable_oasis_section = create "disable_oasis_section" alpha (fun () -> s_ "Allows the OASIS section comments and digest to be omitted in \ generated files.") let no_automatic_syntax = create "no_automatic_syntax" alpha (fun () -> s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ that matches the internal heuristic (if a dependency ends with \ a .syntax or is a well known syntax).") end module OASISUnixPath = struct (* # 22 "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 (* # 22 "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 (* # 22 "src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Object (cs, _, _) -> `Object, 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) | Object (_, bs, obj) -> Object (cs, bs, obj) | 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" | `Object -> "object" | `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 (* # 22 "src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct (* # 22 "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 (* # 22 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists bs 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 bs 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 bs modul with | `Sources (base_fn, [fn]) when ext <> "cmi" && Filename.check_suffix fn ".mli" -> None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> Some [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; Some lst in List.fold_left (fun acc nm -> match find_module nm with | None -> acc | Some base_fns -> List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in (* The .cmx that be compiled along *) let cmxs = let should_be_built = match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then if lib.lib_pack then find_modules [cs.cs_name] "cmx" else find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* The headers and annot/cmt files that should be compiled along *) let headers = let sufx = if lib.lib_pack then [".cmti"; ".cmt"; ".annot"] else [".cmi"; ".cmti"; ".cmt"; ".annot"] in List.map begin List.fold_left begin fun accu s -> let dot = String.rindex s '.' in let base = String.sub s 0 dot in List.map ((^) base) sufx @ accu end [] end (find_modules lib.lib_modules "cmi") 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"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: 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) end module OASISObject = struct (* # 22 "src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = List.fold_left (fun acc modul -> match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name; acc) [] obj.obj_modules let generated_unix_files ~ctxt ~is_native ~source_file_exists (cs, bs, obj) = let find_module ext modul = match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, _) -> [base_fn ^ ext] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name ; lst in let header, byte, native, c_object, f = match obj.obj_modules with | [ m ] -> (find_module ".cmi" m, find_module ".cmo" m, find_module ".cmx" m, find_module ".o" m, fun x -> x) | _ -> ([cs.cs_name ^ ".cmi"], [cs.cs_name ^ ".cmo"], [cs.cs_name ^ ".cmx"], [cs.cs_name ^ ".o"], OASISUnixPath.concat bs.bs_path) in List.map (List.map f) ( match bs.bs_compiled_object with | Native -> native :: c_object :: byte :: header :: [] | Best when is_native -> native :: c_object :: byte :: header :: [] | Byte | Best -> byte :: header :: []) end module OASISFindlib = struct (* # 22 "src/oasis/OASISFindlib.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 of library | `Object of object_] * group_t list) type data = common_section * build_section * [`Library of library | `Object of object_] 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 | Object (cs, _, obj) -> begin let obj_name = cs.cs_name in if MapString.mem obj_name mp then failwithf (f_ "The object name '%s' is used more than once.") obj_name; let findlib_full_name = match obj.obj_findlib_fullname with | Some ns -> String.concat "." ns | None -> obj_name in MapString.add obj_name (`Solved findlib_full_name) 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, `Library lib) mp | Object (cs, bs, obj) -> add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree group_mp in let library_name_of_findlib_name = lazy begin (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty end 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 (* # 22 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 22 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 22 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 22 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 22 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 22 "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 (* # 22 "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 (fun file -> (if case_sensitive then file_exists_case file else Sys.file_exists file) && not (Sys.is_directory file) ) 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 else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") 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 # 2893 "setup.ml" module BaseEnvLight = struct (* # 22 "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 rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 2998 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) (* TODO: get rid of this module. *) open OASISContext let args () = fst (fspecs ()) let default = default end module BaseMessage = struct (* # 22 "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 (* # 22 "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 (* # 22 "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 (* # 22 "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 (* # 22 "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 (* # 22 "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" | "Cygwin" -> ".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 (* # 22 "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 (* # 22 "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 (* # 22 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BObj -> "obj" | 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") | BObj -> (f_ "object %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 let of_object ffn (cs, bs, obj) = let unix_lst = OASISObject.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 ())) (cs, bs, obj) in let evs = [BObj, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 22 "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 (* # 22 "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 _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 22 "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 OASISFeatures.package_test OASISFeatures.flag_tests pkg && 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 (* # 22 "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 OASISFeatures.package_test OASISFeatures.flag_docs pkg && 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 (* # 22 "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 let arg_rest = ref [] 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"; "--", Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure t (Array.of_list (List.rev !arg_rest)); 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 _ | Object _ | 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 default_oasis_fn = "_oasis" let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> default_oasis_fn 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 default_oasis_fn 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 # 5409 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "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; (* Make sure the findlib version is fine for the OCaml compiler. *) begin let ocaml_ge4 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) (OASISVersion.version_of_string "4.0.0") >= 0 in if ocaml_ge4 then let findlib_lt132 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) (OASISVersion.version_of_string "1.3.2") < 0 in if findlib_lt132 then add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" 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 (* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall *) open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes open OASISFindlib 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 obj_hook = ref (fun (cs, bs, obj) -> cs, bs, obj, []) 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 let make_fnames modul sufx = List.fold_right begin fun sufx accu -> (String.capitalize modul ^ sufx) :: (String.uncapitalize modul ^ sufx) :: accu end sufx [] 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 begin fun acc modul -> begin try [List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".mli"; ".ml"]))] with Not_found -> warning (f_ "Cannot find source header for module %s \ in library %s") modul cs.cs_name; [] end @ List.filter OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".annot";".cmti";".cmt"])) @ 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 and files_of_object (f_data, acc) data_obj = let cs, bs, obj, obj_extra = !obj_hook data_obj in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then begin let acc = (* Start with acc + obj_extra *) List.rev_append obj_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left begin fun acc modul -> begin try [List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".mli"; ".ml"]))] with Not_found -> warning (f_ "Cannot find source header for module %s \ in object %s") modul cs.cs_name; [] end @ List.filter OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".annot";".cmti";".cmt"])) @ acc end acc obj.obj_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BObj cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the object *) 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, `Library lib, children) -> files_of_library data_and_files (cs, bs, lib), children | Package (_, cs, bs, `Object obj, children) -> files_of_object data_and_files (cs, bs, obj), 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 # 6273 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) open OASISGettext open BaseEnv open BaseStandardVar open OASISTypes type extra_args = string list 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 (tests ()) then ["-tag"; "tests"] 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 (* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISUtils open OASISString open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage let cond_targets_hook = ref (fun lst -> lst) let build extra_args 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 tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ~what:".cma" fn || ends_with ~what:".cmxs" fn || ends_with ~what:".cmxa" fn || ends_with ~what:(ext_lib ()) fn || ends_with ~what:(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 | Object (cs, bs, obj) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_object in_build_dir_of_unix (cs, bs, obj) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ".cmo" fn || ends_with ".cmx" fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for object %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 _ | Object _ | 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 (fn_ "Expected built file %s doesn't exist." "None of expected built files %s exists." (List.length fns)) (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in (* Run the hook *) let cond_targets = !cond_targets_hook cond_targets in (* Run a list of target... *) run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) 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 (* # 22 "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 type run_t = { extra_args: string list; run_path: unix_filename; } let doc_build run pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ run.run_path; cs.cs_name^".docdir"; "index.html"; ] in let tgt_dir = OASISHostPath.make [ build_dir argv; OASISHostPath.of_unix run.run_path; cs.cs_name^".docdir"; ] in run_ocamlbuild (index_html :: run.extra_args) 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 run pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name end # 6651 "setup.ml" module CustomPlugin = struct (* # 22 "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 # 6799 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build ["-use-ocamlfind"]; 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 = []; 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 = []; 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"); alpha_features = []; beta_features = []; name = "bin_prot"; version = "113.00.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 Group LLC " ]; maintainers = ["Jane Street Group"; "LLC "]; authors = ["Jane Street Group"; "LLC "]; homepage = Some "https://github.com/janestreet/bin_prot"; synopsis = "bin_prot - binary protocol generator"; description = None; categories = []; conf_type = (`Configure, "internal", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [ (OASISExpr.EBool true, Some (("config/arch.sh", ["$ocamlc"]))) ] }; build_type = (`Build, "ocamlbuild", Some "0.4"); build_custom = { pre_command = [ (OASISExpr.EBool true, Some (("mkdir", ["-p"; "_build;"; "cp"; "lib/*.mlh"; "_build/"]))) ]; post_command = [(OASISExpr.EBool true, None)] }; install_type = (`Install, "internal", Some "0.4"); 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 = ["config.h"; "blit_stubs.c"; "float_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"; "Size"; "Write"; "Read"; "Std"; "Type_class"; "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 = "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.4"); 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 "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 = "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.4"); 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 "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 = "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"}) ]; plugins = [ (`Extra, "StdFiles", Some "0.3"); (`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3") ]; disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; oasis_digest = Some "\155\199\022\184-\134\017\198d\t:\240X|\251\208"; oasis_exec = None; oasis_setup_args = []; setup_update = false };; let setup () = BaseSetup.setup setup_t;; # 7207 "setup.ml" (* OASIS_STOP *) let () = setup () bin_prot-113.00.00/syntax/000077500000000000000000000000001256461074100151645ustar00rootroot00000000000000bin_prot-113.00.00/syntax/pa_bin_prot.ml000066400000000000000000001310571256461074100200210ustar00rootroot00000000000000(** 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 let rec_flag_of_bool = function | true -> Ast.ReRecursive | false -> Ast.ReNil let let_ins _loc bindings expr = List.fold_right (fun binding expr -> <:expr< let $binding$ in $expr$ >> ) bindings expr let alias_or_fun expr fct = let is_id = match expr with | <:expr< $id:_$ >> -> true | _ -> false in if is_id then expr else fct ;; (* 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.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_size, bin_writer = loop <:ctyp< $this_type$ $tp$ >> tps in <:ctyp< Bin_prot.Write.writer $tp$ -> $bin_write$ >>, <:ctyp< Bin_prot.Size.sizer $tp$ -> $bin_size$ >>, <:ctyp< Bin_prot.Type_class.writer $tp$ -> $bin_writer$ >> in let bin_write, 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_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.reader $this_tp$ >>, <:ctyp< Bin_prot.Read.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_reader = loop <:ctyp< $this_tp$ $tp$ >> tps in <:ctyp< Bin_prot.Read.reader $tp$ -> $bin_read$ >>, <:ctyp< Bin_prot.Read.reader $tp$ -> $__bin_read__$ >>, <:ctyp< Bin_prot.Type_class.reader $tp$ -> $bin_reader$ >> in let 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_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 -> alias_or_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.Write.bin_write_array >>, `Fun <:expr< Bin_prot.Write.bin_write_float >> -> <:expr< Bin_prot.Write.bin_write_float_array >> | `Fun fun_expr1, `Fun fun_expr2 -> <:expr< $fun_expr1$ $fun_expr2$ >> | `Fun fun_expr, `Match matching -> <:expr< $fun_expr$ (fun buf ~pos -> 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$ buf ~pos $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 pos = $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$ -> Bin_prot.Write.bin_write_variant_int buf ~pos $`int:Pa_type_conv.hash_variant cnstr$ >> | <:ctyp< `$cnstr$ of $tp$ >> -> let write_args = match bin_write_type full_type_name _loc tp with | `Fun fun_expr -> <:expr< $fun_expr$ buf ~pos args >> | `Match matchings -> <:expr< match args with [ $matchings$ ] >> in <:match_case< `$cnstr$ args -> let pos = Bin_prot.Write.bin_write_variant_int buf ~pos $`int:Pa_type_conv.hash_variant cnstr$ 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$ buf ~pos 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$ buf ~pos 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 _buf ~pos:_ _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.Write.bin_write_int_8bit buf ~pos >> else if n_alts <= 65536 then <:expr< Bin_prot.Write.bin_write_int_16bit buf ~pos >> 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 pos = $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 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 _buf ~pos:_ _v -> $expr$ >> | `Fun fun_expr -> alias_or_fun fun_expr <:expr< fun buf ~pos v -> $fun_expr$ buf ~pos v >> | `Match matchings -> <:expr< fun buf ~pos -> 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 write_name = "bin_write_" ^ type_name in let size_name = "bin_size_" ^ type_name in ( <:binding< $lid:write_name$ = $Gen.abstract _loc tparam_patts body$ >>, 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 alias_or_fun call <:expr< fun v -> $call$ v >> in let tparam_write_exprs = List.map (fun tp -> <:expr< $lid:"bin_writer_" ^ Gen.get_tparam_id tp$ .Bin_prot.Type_class.write >>) tps in let write = let call = Gen.apply _loc <:expr< $lid:write_name$ >> tparam_write_exprs in alias_or_fun call <:expr< fun buf ~pos v -> $call$ buf ~pos v >> in let write = <:expr< { Bin_prot.Type_class. size = $size$; 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 write_bindings, writer_bindings, recursive, _loc = match tds with | TyDcl (_loc, type_name, tps, rhs, _cl) -> let write_binding, writer_binding = bin_write_td _loc type_name tps rhs in [write_binding], [writer_binding], rec_ && Gen.type_is_recursive type_name rhs, _loc | TyAnd (_loc, _, _) -> let res = bin_write_tds [] tds in let write_bindings, writer_bindings = List.split res in write_bindings, writer_bindings, rec_, _loc | _ -> assert false (* impossible *) in <:str_item< $Generate_bin_size.bin_size rec_ tds$; value $rec:rec_flag_of_bool recursive$ $list:write_bindings$; value $list:writer_bindings$ >> (* 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 buf ~pos_ref -> $expr$ >> | `Closed expr -> expr let get_open_expr _loc = function | `Open expr -> expr | `Closed expr -> <:expr< $expr$ buf ~pos_ref >> (* 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$ >>, abs1 @ 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.Read.bin_read_array >>, <:expr< Bin_prot.Read.bin_read_float >> -> `Closed <:expr< Bin_prot.Read.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, bs1 @ 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 (let_ins _loc bindings <:expr< ( $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 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< $`int:Pa_type_conv.hash_variant cnstr$ -> `$cnstr$ >> 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 = let_ins _loc bnds <:expr< `$cnstr$ $args_expr$ >> in let this_mc = <:match_case< $`int:Pa_type_conv.hash_variant 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$ buf ~pos_ref 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.Read.bin_read_variant_int buf ~pos_ref in try $code$ with [ Bin_prot.Common.No_variant_match -> Bin_prot.Common.raise_variant_wrong_type $str:full_type_name$ !pos_ref ] >> 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 _buf ~pos_ref -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Poly_rec_bound $str:full_type_name$) !pos_ref >> 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 = let_ins _loc bindings <:expr< $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.Read.bin_read_int_8bit >> else if n_alts <= 65536 then <:expr< Bin_prot.Read.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$ buf ~pos_ref with [ $mcs$ | _ -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Sum_tag $str:full_type_name$) !pos_ref ] >> (* 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 ( bs1 @ 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 (let_ins _loc bindings <:expr< { $rec_bindings$ } >>) (* Empty types *) let bin_read_nil full_type_name _loc = `Closed <:expr< fun _buf ~pos_ref -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Empty_type $str:full_type_name$) !pos_ref >> (* 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 full_type_name) in loop _loc rhs in let read_name = "bin_read_" ^ type_name in let vtag_read_name = "__bin_read_" ^ type_name ^ "__" in let read_binding = let body = if !is_variant_ref then (* The type is a polymorphic variant: the main bin_read_NAME function reads an integer and calls the __bin_read_NAME__ function wrapped into a try-with. *) let vtag_read_expr = <:expr< $lid:vtag_read_name$ >> in <:expr< fun buf ~pos_ref -> let vint = Bin_prot.Read.bin_read_variant_int buf ~pos_ref in try $Gen.apply _loc vtag_read_expr arg_exprs$ buf ~pos_ref vint with [ Bin_prot.Common.No_variant_match -> let err = Bin_prot.Common.ReadError.Variant $str:full_type_name$ in Bin_prot.Common.raise_read_error err !pos_ref ] >> else match oc_body with | `Closed expr -> alias_or_fun expr <:expr< fun buf ~pos_ref -> $expr$ buf ~pos_ref >> | `Open body -> <:expr< fun buf ~pos_ref -> $body$ >> in let func = Gen.abstract _loc arg_patts body in <:binding< $lid:read_name$ = $func$ >> in let vtag_read_binding = let body = let wrong_type = <:expr< fun _buf ~pos_ref _vint -> Bin_prot.Common.raise_variant_wrong_type $str:full_type_name$ !pos_ref >> 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.Read.$_$ >> -> wrong_type | <:expr< $lid:name$ >> when name.[0] = '_' && name.[1] = 'o' -> (* change [buf] -> [_buf] to fix unused-var warning in generated code *) <:expr< fun _buf ~pos_ref _vint -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Silly_type $str:full_type_name$) !pos_ref >> | <: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 let cnv_expr = cnv expr in alias_or_fun cnv_expr <:expr< fun buf ~pos_ref vint -> $cnv_expr$ buf ~pos_ref 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 buf ~pos_ref:_ vint -> $body$ >> | `Open body -> <:expr< fun buf ~pos_ref vint -> $body$ >> | _ -> assert false (* impossible *) else wrong_type in let func = Gen.abstract _loc arg_patts body in <:binding< $lid:vtag_read_name$ = $func$ >> in let tparam_read_exprs = List.map (fun tp -> <:expr< $lid:"bin_reader_" ^ Gen.get_tparam_id tp$ .Bin_prot.Type_class.read >>) tps in let read = let call = Gen.apply _loc <:expr< $lid:read_name$ >> tparam_read_exprs in alias_or_fun call <:expr< fun buf ~pos_ref -> $call$ buf ~pos_ref >> in let vtag_read = let call = Gen.apply _loc <:expr< $lid:vtag_read_name$ >> tparam_read_exprs in alias_or_fun call <:expr< fun buf ~pos_ref vtag -> $call$ buf ~pos_ref vtag >> in let reader = <:expr< { Bin_prot.Type_class. read = $read$; vtag_read = $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 (vtag_read_binding, (read_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, _, _) -> if not rec_ then begin (* there can be captures in the generated code if we allow this *) Loc.raise _loc (Failure "bin_prot doesn't support multiple nonrecursive definitions.") end; bin_read_tds rec_ [] tds, rec_, _loc | _ -> assert false (* impossible *) in let vtag_read_bindings, read_and_reader_bindings = List.split res in let read_bindings, reader_bindings = List.split read_and_reader_bindings in let defs = if recursive then <:str_item< value rec $list:vtag_read_bindings @ read_bindings$; >> else let cnv binding = <:str_item< value $binding$ >> in <:str_item< $list:List.map cnv vtag_read_bindings$; $list:List.map cnv read_bindings$; >> in <:str_item< $defs$; value $list:reader_bindings$; >> (* 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-113.00.00/syntax/pa_bin_prot.mldylib000066400000000000000000000001401256461074100210310ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 0f1a15b21854bc6a0f9c98fd964cb6fc) Pa_bin_prot # OASIS_STOP bin_prot-113.00.00/syntax/pa_bin_prot.mli000066400000000000000000000001111256461074100201540ustar00rootroot00000000000000(** Pa_bin_prot: Preprocessing Module for a Type Safe Binary Protocol *) bin_prot-113.00.00/syntax/pa_bin_prot.mllib000066400000000000000000000001401256461074100204740ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 0f1a15b21854bc6a0f9c98fd964cb6fc) Pa_bin_prot # OASIS_STOP bin_prot-113.00.00/test/000077500000000000000000000000001256461074100146155ustar00rootroot00000000000000bin_prot-113.00.00/test/bin_prot_test.ml000066400000000000000000001020751256461074100200270ustar00rootroot00000000000000open 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 let test = "Bin_prot" >::: [ "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)); (* Test that the binary forms of [float array] and [float_array] are the same *) let arrays = let rec loop acc len = if len < 0 then acc else let a = Array.init len (fun i -> float_of_int (i + len)) in let txt = Printf.sprintf "float array, len = %d" len in let buf = len * 8 + Size.bin_size_nat0 (Nat0.unsafe_of_int len) in loop ((a, txt, buf) :: acc) (len - 1) in loop [] 255 in let len = 255 * 8 + Size.bin_size_nat0 (Nat0.unsafe_of_int 255) in check_all len "float array -> float_array" Read.bin_read_float_array (Write.bin_write_array Write.bin_write_float) arrays; check_all len "float_array -> float array" (Read.bin_read_array Read.bin_read_float) (Write.bin_write_float_array) arrays; (* Check that the canonical closures used in the short circuit test of float arrays are indeed allocated closures as opposed to [compare] for example which is a primitive. Even if it looks like a tautology, it is not. (for example, [compare == compare] is false. *) assert (bin_write_float == bin_write_float); assert (bin_read_float == bin_read_float); assert (bin_size_float == bin_size_float); ); "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); ] ); "bigstring (big)" >:: (fun () -> (* [n] is a 16bits integer that will be serialized differently depending on whether it is considered as an integer or an unsigned integer. *) let n = 40_000 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_int Write.bin_write_variant_int [ ((Obj.magic `Foo : int), "`Foo", 4); ((Obj.magic `Bar : int), "`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_int 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); ]; ); ] 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.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-113.00.00/test/bin_prot_test_nonrec.ml000066400000000000000000000007271256461074100213740ustar00rootroot00000000000000open 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-113.00.00/test/blob_test.ml000066400000000000000000000057321256461074100171330ustar00rootroot00000000000000open Bin_prot.Std open Bin_prot.Blob module Mystery = struct type t = { name : string ; age : int ; favorite_colors : string list } with bin_io let value = { name = "Drew" ; age = 25 ; favorite_colors = [ "Blue"; "Yellow" ] } end module T = struct type 'a t = { header : string ; mystery : 'a ; footer : string } with bin_io let value mystery = { header = "header" ; mystery ; footer = "footer" } end (* Some Rumsfeldian tests follow... *) module Known = struct type nonrec t = Mystery.t t T.t with bin_io let value = T.value Mystery.value end module Unknown = struct type t = Opaque.t T.t with bin_io let value = T.value (to_opaque Mystery.value Mystery.bin_writer_t) end let convert bin_writer bin_reader value = let buffer = Bin_prot.Utils.bin_dump bin_writer value in bin_reader.Bin_prot.Type_class.read buffer ~pos_ref:(ref 0) let roundtrip { Bin_prot.Type_class. reader; writer } value = assert (convert writer reader value = value) module Dropped = struct type t = Ignored.t T.t with bin_read let bin_size_t = T.bin_size_t Ignored.bin_size_t end let bigstring_to_string bigstring = let len = Bigarray.Array1.dim bigstring in let s = String.create len in for i = 0 to len - 1 do s.[i] <- bigstring.{i} done; s let test = let open OUnit in "Blob_test" >::: [ "roundtrip known" >:: (fun () -> roundtrip Known.bin_t Known.value); "roundtrip unknown" >:: (fun () -> roundtrip Unknown.bin_t Unknown.value); "opaque and wrapped serialize the same way" >:: (fun () -> let known_buffer = Bin_prot.Utils.bin_dump Known.bin_writer_t Known.value in let unknown_buffer = Bin_prot.Utils.bin_dump Unknown.bin_writer_t Unknown.value in let known_s = bigstring_to_string known_buffer in let unknown_s = bigstring_to_string unknown_buffer in if known_s <> unknown_s then failwith (Printf.sprintf "%s <> %s" known_s unknown_s)); "serialized wrapped deserializes to the expected opaque" >:: (fun () -> let unknown_from_known = convert Known.bin_writer_t Unknown.bin_reader_t Known.value in assert (Unknown.value = unknown_from_known)); "serialized opaque deserializes to the expected wrapped" >:: (fun () -> let known_from_unknown = convert Unknown.bin_writer_t Known.bin_reader_t Unknown.value in assert (Known.value = known_from_unknown)); "Dropped" >:: (fun () -> let buffer = Bin_prot.Utils.bin_dump Known.bin_writer_t Known.value in let value = Dropped.bin_reader_t.Bin_prot.Type_class.read buffer ~pos_ref:(ref 0) in let ignored = value.mystery in (* The value deserialized with [Dropped] agrees with the value serialized by [Known], except for the ignored bit. *) assert ({ Known.value with mystery = ignored} = value ); (* [Dropped] remembered the size of the ignored data. *) assert (Dropped.bin_size_t value = Known.bin_size_t Known.value)); ] bin_prot-113.00.00/test/example.ml000066400000000000000000000027241256461074100166070ustar00rootroot00000000000000open 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-113.00.00/test/mac_test.ml000066400000000000000000000052301256461074100167460ustar00rootroot00000000000000open 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-113.00.00/test/microbench.ml000066400000000000000000000051411256461074100172610ustar00rootroot00000000000000open Core.Std open Core_bench.Std let write_bin_prot writer buf ~pos a = let len = writer.Bin_prot.Type_class.size a in assert(writer.Bin_prot.Type_class.write buf ~pos a = pos + len) let read_bin_prot reader buf ~pos_ref = reader.Bin_prot.Type_class.read buf ~pos_ref let pos_ref = ref 0 let one = if Random.bool () then 1.0 else 1.0 let pi = if Random.bool () then 3.141597 else 3.141597 let read_float x = let buf = Bigstring.create 100 in write_bin_prot Float.bin_writer_t buf x ~pos:0; (fun () -> pos_ref := 0; ignore(read_bin_prot Float.bin_reader_t buf ~pos_ref : float)) let write_float x = let buf = Bigstring.create 100 in (fun () -> write_bin_prot Float.bin_writer_t buf x ~pos:0) module R = struct type t = { x : float; y : float } with bin_io end let read_r x = let buf = Bigstring.create 100 in write_bin_prot R.bin_writer_t buf x ~pos:0; (fun () -> pos_ref := 0; ignore(read_bin_prot R.bin_reader_t buf ~pos_ref : R.t)) let write_r x = let buf = Bigstring.create 100 in (fun () -> write_bin_prot R.bin_writer_t buf x ~pos:0) let r_one : R.t = if Random.bool () then { x = 1.0; y = 1.0 } else { x = 1.0; y = 1.0 } let r_pi : R.t = if Random.bool () then { x = pi ; y = pi } else { x = pi ; y = pi } let lengths = [0; 1; 10; 100; 1000; 10_000] let write_float_array len = let arr = Array.create ~len 1.0 in let buf = Bigstring.create 1_000_000 in Staged.stage (fun () -> write_bin_prot bin_writer_float_array buf arr ~pos:0) let read_float_array len = let arr = Array.create ~len 1.0 in let buf = Bigstring.create 1_000_000 in write_bin_prot bin_writer_float_array buf arr ~pos:0; Staged.stage (fun () -> pos_ref := 0; let arr = read_bin_prot bin_reader_float_array buf ~pos_ref in if not (Array.length arr = len) then failwithf "got len %d, expected %d" (Array.length arr) len ()) let benchs = [ Bench.Test.create ~name:"write float one" (write_float one) ; Bench.Test.create ~name:"read float one" (read_float one) ; Bench.Test.create ~name:"write float pi" (write_float pi) ; Bench.Test.create ~name:"read float pi" (read_float pi) ; Bench.Test.create ~name:"write record one" (write_r r_one) ; Bench.Test.create ~name:"read record one" (read_r r_one) ; Bench.Test.create ~name:"write record pi" (write_r r_pi) ; Bench.Test.create ~name:"read record pi" (read_r r_pi) ; Bench.Test.create_indexed ~name:"write float array" ~args:lengths (write_float_array) ; Bench.Test.create_indexed ~name:"read float array" ~args:lengths (read_float_array) ] let () = Command.run (Bench.make_command benchs) bin_prot-113.00.00/test/qtest.ml000066400000000000000000000002011256461074100163000ustar00rootroot00000000000000(** Regression test runner. *) let tests = Qtest_lib.Std.Test.tests_of_ounit Test.all let () = Qtest_lib.Std.Runner.main tests bin_prot-113.00.00/test/test.ml000066400000000000000000000001761256461074100161320ustar00rootroot00000000000000open OUnit let all = TestList [ Bin_prot_test.test; Bin_prot_test.Common.test; Blob_test.test; ] bin_prot-113.00.00/test/test_runner.ml000066400000000000000000000000701256461074100175140ustar00rootroot00000000000000open OUnit let () = ignore (run_test_tt_main Test.all)