pax_global_header00006660000000000000000000000064147650345240014524gustar00rootroot0000000000000052 comment=d5c0a7741b2ed9351f09d939bb1ad7d4fd7d0f3c monolith-20250314/000077500000000000000000000000001476503452400136175ustar00rootroot00000000000000monolith-20250314/.gitignore000066400000000000000000000001001476503452400155760ustar00rootroot00000000000000_build .merlin *~ dune-workspace.afl monolith.opam input output monolith-20250314/AUTHORS.md000066400000000000000000000000561476503452400152670ustar00rootroot00000000000000François Pottier monolith-20250314/CHANGES.md000066400000000000000000000213131476503452400152110ustar00rootroot00000000000000# Changes ## 2025/03/14 * The new function `run` can be used to start Monolith's testing engine without allowing Monolith to parse the command line. The function `main`, which parses the command line and starts testing, can still be used. (Suggested by Gabriel Scherer.) * If the command line is parsed via `main` then the command line options `--fuel ` and `--max_scenarios ` and `--save-scenario ` and `--show-scenario ` and `--timeout ` are supported. * In random testing mode, a single counter and clock is now used for all tests, whereas previously a fresh counter and clock would be created every time a smaller value of `fuel` was adopted. This affects the information messages that are emitted once every second. (Contributed by Gabriel Scherer.) * The internal error `Argh -- reached max environment size`, which under infrequent circumstances could appear, has been eliminated. * `Makefile.monolith`: change `make unattended` to use random testing mode instead of AFL mode and to stop after `TIMEOUT` seconds or `MAX` failure scenarios have been reached. As a result, Monolith's own `make test` now runs reliably in about 20 seconds (wall clock time) on a modern machine. ## 2024/11/26 * The documentation of the specification combinators has been re-organized in sections and subsections. Finding the desired combinator should now be easier. * The new combinator `naive_array` offers limited support for arrays. * The new combinator `naive_seq` offers limited support for sequences (that is, for the type constructor `Seq.t`). * The new combinator `pair` is a synonym for `( *** )`. * The new combinator `triple` offers support for triples. * The new combinator `either` offers support for the type constructor `Either.t`. * The new combinators `iter`, `foldr`, `foldl`, `iteri`, `foldri`, `foldli` offer support for iteration functions. * An unintentional and undocumented limitation has been fixed: so far, uses of the combinator `map_into` would work only at the root of the specification or in the right-hand side of an arrow `^>`. It should now be possible to use `map_into` under other combinators that expect a deconstructible specification, such as `^!>` (in the right-hand side), `( *** )`, `option`, `result`, `list`, etc. This improvement affects not only `map_into`, but also a number of other combinators that are defined in terms of `map_into`. * Monolith now requires OCaml 4.12 or later. * In `Makefile.monolith`, + the default switch is changed from 4.11.1 to 4.14.2; this can be overridden by defining `SWITCH`; + `make test` automatically disables the MacOS crash reporter; + the use of `ulimit -s` is abandoned. ## 2023/06/04 * Fix a bug in `Gen.with_source` where a file descriptor was not properly closed, causing Monolith to eventually run out of descriptors. (Contributed by Samuel Hym.) * Fix a minor bug that could cause an assertion failure while printing an error scenario. * Fix a bug in `Makefile.monolith` that would cause `make test` to launch multiple instances of `dune` in parallel and therefore to fail. * Remove the use of `Obj.magic` in module `Tag`. ## 2021/05/25 * Fix a bug where the exception `PleaseBackOff` was unintendedly caught by the combinator `^!>` and therefore did not work as intended. (Reported and fixed by Nicolas Osborne.) ## 2020/10/26 * The functions `declare_concrete_type`, `&&&` and `&&@` disappear. They are replaced with two new combinators, `constructible` and `deconstructible`. The combinator `ifpol` (described further on) can be used to construct a specification that is both constructible and deconstructible. The idiom `int &&& range` is replaced with `int_within range`. * The function `declare_abstract_type` no longer requires the type's name as an argument; it takes a unit argument instead. * The arrow combinator `^^>` is renamed `^>`. The dependent arrow combinator `^&>` is renamed `^>>`. * New specification combinator `^!>`. This combinator describes a function that can raise an exception, and requires the reference implementation and the candidate implementation to raise exactly the same exception. * New specification combinator `^?>`. This combinator describes a nondeterministic function. `spec1 ^?> spec2` is a short-hand for `spec1 ^> nondet spec2`. * New specification combinator `^!?>`. This combinator describes a function that can raise an exception, and can decide in a nondeterministic way whether it wishes to raise an exception and what exception it wishes to raise. The reference implementation is allowed to observe this behavior and to react accordingly. * New specification combinators `^!>>`, `^?>>`, and `^!?>>`. These are the dependent variants of the previous three combinators. * New specification combinators `option`, `result`, and `list`. These combinators make it easy to describe an operation that expects or returns an option, a result, or a list. * New specification combinator `declare_seq`. This (effectful) combinator makes it relatively easy to describe an operation that expects or returns a sequence. * New specification combinator `map_into`. This combinator is typically used to wrap an operation or to transform the result of an operation. * New specification combinator `map_outof`. This combinator is typically used to construct an argument to an operation via a transformation. * Removed the combinator `map`, whose type was fishy. * New specification combinators `rot2` and `rot3`. (`rot2` is also known as `flip`.) These combinators move a distant argument to the front. This is useful when a dependency between arguments runs contrary to the order of the arguments. These combinators can be used only in a positive position. * New specification combinators `curry` and `uncurry`. These combinators transform a function that expects a pair into a function that expects two separate arguments, and vice-versa. These combinators can be used only in a positive position. * New specification combinator `ignored`. This combinator is used to describe the output (or part of the output) of an operation, and indicates that this output should be ignored. * Changed the type of the specification combinator `nondet`. Removed the limitation that this combinator can be applied only to a concrete type. * New specification constant `exn`. The new function `override_exn_eq` allows overriding the notion of equality that is associated with the concrete type `exn`. This is useful when the reference implementation and candidate implementation raise different exceptions. * New specification combinator `ifpol`, which allows distinguishing between negative and positive occurrences in a specification. This low-level combinator can be useful in the definition of higher-level abstractions. * New specification combinator `fix`, which allows building recursive specifications. * New specification combinator `abstract`, which declares an abstract type on the fly, together with a conversion operation out of this abstract type to its concrete definition. This can be used to deal with functions that return functions. * New exception `PleaseBackOff`, which the reference implementation is allowed to raise when an operation (or some particular case of an operation) is illegal or is not implemented. This causes the Monolith engine to silently ignore this scenario. No side effects must be performed by the reference implementation before raising this exception. * New exception `Unimplemented`, which the candidate implementation is allowed to raise when an operation (or some particular case of an operation) is not implemented. This causes the Monolith engine to silently ignore this scenario. * New definition of the type `'a code` as a synonym for `'a * appearance`. New constructors for the type `appearance`, including `constant`, `document`, and `infix`. * The functions `interval` and `interval_` are renamed `semi_open_interval` and `closed_interval`. * Significant internal changes, leading to simpler and possibly faster code. * The file `Makefile.monolith` is now installed with the library, so it need no longer be copied into one's project, unless one wishes to adapt it. * In `Makefile.monolith`, new entries `make multicore` and `make tmux`, both of which implement parallel fuzzing with multiple `afl-fuzz` processes. * In `Makefile.monolith`, new entry `make random`, which implements random testing. * On 64-bit machines, the function `bits` did not generate the full range of 63-bit integers; it was inadvertently limited to 32-bit integers. A number of other functions that depend on it, such as `interval`, were also wrong. Fixed (hopefully). ## 2020/06/09 * Initial release. monolith-20250314/LICENSE000066400000000000000000001243441476503452400146340ustar00rootroot00000000000000All files in this directory are distributed under the terms of the GNU Lesser General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. Version 3 of the GNU Lesser General Public License is included bellow. ---------------------------------------------------------------------- GNU LESSER GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. This version of the GNU Lesser General Public License incorporates the terms and conditions of version 3 of the GNU General Public License, supplemented by the additional permissions listed below. 0. Additional Definitions. As used herein, "this License" refers to version 3 of the GNU Lesser General Public License, and the "GNU GPL" refers to version 3 of the GNU General Public License. "The Library" refers to a covered work governed by this License, other than an Application or a Combined Work as defined below. An "Application" is any work that makes use of an interface provided by the Library, but which is not otherwise based on the Library. Defining a subclass of a class defined by the Library is deemed a mode of using an interface provided by the Library. A "Combined Work" is a work produced by combining or linking an Application with the Library. The particular version of the Library with which the Combined Work was made is also called the "Linked Version". The "Minimal Corresponding Source" for a Combined Work means the Corresponding Source for the Combined Work, excluding any source code for portions of the Combined Work that, considered in isolation, are based on the Application, and not on the Linked Version. The "Corresponding Application Code" for a Combined Work means the object code and/or source code for the Application, including any data and utility programs needed for reproducing the Combined Work from the Application, but excluding the System Libraries of the Combined Work. 1. Exception to Section 3 of the GNU GPL. You may convey a covered work under sections 3 and 4 of this License without being bound by section 3 of the GNU GPL. 2. Conveying Modified Versions. If you modify a copy of the Library, and, in your modifications, a facility refers to a function or data to be supplied by an Application that uses the facility (other than as an argument passed when the facility is invoked), then you may convey a copy of the modified version: a) under this License, provided that you make a good faith effort to ensure that, in the event an Application does not supply the function or data, the facility still operates, and performs whatever part of its purpose remains meaningful, or b) under the GNU GPL, with none of the additional permissions of this License applicable to that copy. 3. Object Code Incorporating Material from Library Header Files. The object code form of an Application may incorporate material from a header file that is part of the Library. You may convey such object code under terms of your choice, provided that, if the incorporated material is not limited to numerical parameters, data structure layouts and accessors, or small macros, inline functions and templates (ten or fewer lines in length), you do both of the following: a) Give prominent notice with each copy of the object code that the Library is used in it and that the Library and its use are covered by this License. b) Accompany the object code with a copy of the GNU GPL and this license document. 4. Combined Works. You may convey a Combined Work under terms of your choice that, taken together, effectively do not restrict modification of the portions of the Library contained in the Combined Work and reverse engineering for debugging such modifications, if you also do each of the following: a) Give prominent notice with each copy of the Combined Work that the Library is used in it and that the Library and its use are covered by this License. b) Accompany the Combined Work with a copy of the GNU GPL and this license document. c) For a Combined Work that displays copyright notices during execution, include the copyright notice for the Library among these notices, as well as a reference directing the user to the copies of the GNU GPL and this license document. d) Do one of the following: 0) Convey the Minimal Corresponding Source under the terms of this License, and the Corresponding Application Code in a form suitable for, and under terms that permit, the user to recombine or relink the Application with a modified version of the Linked Version to produce a modified Combined Work, in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source. 1) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (a) uses at run time a copy of the Library already present on the user's computer system, and (b) will operate properly with a modified version of the Library that is interface-compatible with the Linked Version. e) Provide Installation Information, but only if you would otherwise be required to provide such information under section 6 of the GNU GPL, and only to the extent that such information is necessary to install and execute a modified version of the Combined Work produced by recombining or relinking the Application with a modified version of the Linked Version. (If you use option 4d0, the Installation Information must accompany the Minimal Corresponding Source and Corresponding Application Code. If you use option 4d1, you must provide the Installation Information in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source.) 5. Combined Libraries. You may place library facilities that are a work based on the Library side by side in a single library together with other library facilities that are not Applications and are not covered by this License, and convey such a combined library under terms of your choice, if you do both of the following: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities, conveyed under the terms of this License. b) Give prominent notice with the combined library that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 6. Revised Versions of the GNU Lesser General Public License. The Free Software Foundation may publish revised and/or new versions of the GNU Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library as you received it specifies that a certain numbered version of the GNU Lesser General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that published version or of any later version published by the Free Software Foundation. If the Library as you received it does not specify a version number of the GNU Lesser General Public License, you may choose any version of the GNU Lesser General Public License ever published by the Free Software Foundation. If the Library as you received it specifies that a proxy can decide whether future versions of the GNU Lesser General Public License shall apply, that proxy's public statement of acceptance of any version is permanent authorization for you to choose that version for the Library. ---------------------------------------------------------------------- GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . monolith-20250314/Makefile000066400000000000000000000154741476503452400152720ustar00rootroot00000000000000SHELL := bash # ------------------------------------------------------------------------------ # The name of the library. THIS := monolith # The version number is automatically set to the current date, # unless DATE is defined on the command line. # An example of the date format is 20241208. DATE := $(shell /bin/date +%Y%m%d) # The date, with slahes, is used in [make release] to search CHANGES.md. # An example is 2024/12/08. DATE_WITH_SLASHES := $(shell echo "${DATE}" \ | sed -e 's|\([0-9][0-9][0-9][0-9]\)\([0-9][0-9]\)\([0-9][0-9]\)|\1/\2/\3|') # The repository URL (https). REPO := https://gitlab.inria.fr/fpottier/$(THIS) # The archive URL (https). ARCHIVE := $(REPO)/-/archive/$(DATE)/archive.tar.gz # We assume that all of the demos (which also serve as tests) # exist at depth two under demos/. The following command lists them. DEMOS = $(FIND) demos -mindepth 2 -maxdepth 2 -type d # ------------------------------------------------------------------------------ # [make all] compiles just the library (in the current opam switch). .PHONY: all all: @ dune build @check # [make clean] cleans up. .PHONY: clean clean: @ git clean -dfX # ------------------------------------------------------------------------------ # [make test] runs all demos in unattended mode. # We can use either xargs or GNU parallel, # so as to run multiple tests either sequentially or in parallel. # The number of jobs in parallel mode must be limited, # otherwise afl-fuzz appears to fail. # Every demo is expected to inhabit a subsubdirectory of demos. # Naively running [make unattended] in every demo directory in parallel does # not work, because this causes dune to be run in every demo directory in # parallel, and dune apparently does not allow this. To work around this # issue, we first compile everything using one [make all] invocation at the # toplevel, then we run [make unattended_norebuild] in every demo directory. # LOOP := xargs -n1 LOOP := parallel --no-notice --jobs 8 --group .PHONY: test test: # @ make dependencies # @ make clean @ make -f Makefile.monolith all --no-print-directory @ $(DEMOS) \ | $(LOOP) make unattended_norebuild --no-print-directory -C # [make dependencies] installs the libraries required by the demos. # [dune external-lib-deps] has been deprecated. # [dune describe external-lib-deps] has appeared in Dune 3.6, # but produces an S-expression that is not directly usable. # Let's just hardcode here the libraries needed by the demos. LIBS = \ ptmap \ fix \ containers containers-data \ batteries \ .PHONY: dependencies dependencies: @ for i in $$(make -f Makefile.monolith --no-print-directory switch) ; do \ echo "Installing dependencies in switch $$i..." ; \ opam install --switch $$i $(LIBS) ; \ done # ------------------------------------------------------------------------------ .PHONY: install install: @ dune build @install @ dune install -p $(THIS) .PHONY: uninstall uninstall: @ dune build @install @ dune uninstall .PHONY: reinstall reinstall: @ make uninstall @ make install .PHONY: pin pin: opam pin add $(THIS) . --yes .PHONY: unpin unpin: opam pin remove $(THIS) --yes .PHONY: repin repin: @make unpin @make pin # ---------------------------------------------------------------------------- # [make headache] copies a header to every source file. # This requires a version of headache that supports UTF-8. HEADACHE := headache HEADER := $(shell pwd)/header.txt # The find utility. FIND := $(shell if command -v gfind >/dev/null ; \ then echo gfind ; else echo find ; fi) .PHONY: headache headache: $(FIND) . -regex ".*\.ml\(i\|y\|l\)?" \ -exec $(HEADACHE) -h $(HEADER) "{}" ";" ; \ # ---------------------------------------------------------------------------- # [make versions] compiles and tests the library under many versions of # OCaml, whose list is specified below. # This requires appropriate opam switches to exist. A missing switch # can be created like this: # opam switch create 4.03.0 VERSIONS := \ 4.12.0 \ 4.13.1 \ 4.14.2 \ 5.0.0 \ 5.1.0 \ 5.2.0 \ 5.3.0 \ .PHONY: versions versions: @(echo "(lang dune 2.0)" && \ for v in $(VERSIONS) ; do \ echo "(context (opam (switch $$v)))" ; \ done) > dune-workspace.versions @ dune build --workspace dune-workspace.versions src ; \ result=$$? ; \ rm -f dune-workspace.versions ; \ exit $$result # [make handiwork] runs a command in every opam switch. .PHONY: handiwork handiwork: @ current=`opam switch show` ; \ for v in $(VERSIONS) ; do \ echo "Switching to $$v..." ; \ opam switch $$v && \ eval $$(opam env) && \ opam install --yes afl-persistent && dune build src ; \ done ; \ opam switch $$current # ---------------------------------------------------------------------------- DOCDIR = _build/default/_doc/_html DOC = $(DOCDIR)/index.html .PHONY: doc doc: @ dune build @doc @ echo "You can view the documentation by typing 'make view'". .PHONY: view view: doc @ echo Attempting to open $(DOC)... @ if command -v firefox > /dev/null ; then \ firefox $(DOC) ; \ else \ open -a /Applications/Firefox.app/ $(DOC) ; \ fi .PHONY: export export: doc ssh yquem.inria.fr rm -rf public_html/$(THIS)/doc scp -r $(DOCDIR) yquem.inria.fr:public_html/$(THIS)/doc # ---------------------------------------------------------------------------- .PHONY: release release: # Make sure the current version can be compiled and installed. @ make uninstall @ make clean @ make install # Check the current package description. @ opam lint # Check if this is the master branch. @ if [ "$$(git symbolic-ref --short HEAD)" != "master" ] ; then \ echo "Error: this is not the master branch." ; \ git branch ; \ exit 1 ; \ fi # Make sure a CHANGES entry with the current date seems to exist. @ if ! grep $(DATE_WITH_SLASHES) CHANGES.md ; then \ echo "Error: CHANGES.md has no entry with date $(DATE_WITH_SLASHES)." ; \ exit 1 ; \ fi # Check if everything has been committed. @ if [ -n "$$(git status --porcelain)" ] ; then \ echo "Error: there remain uncommitted changes." ; \ git status ; \ exit 1 ; \ else \ echo "Now making a release..." ; \ fi # Create a git tag. @ git tag -a $(DATE) -m "Release $(DATE)." # Upload. (This automatically makes a .tar.gz archive available on gitlab.) @ git push @ git push --tags # Done. @ echo "Done." @ echo "If happy, please type:" @ echo " \"make publish\" to publish a new opam package" @ echo " \"make export\" to upload the documentation to yquem.inria.fr" .PHONY: publish publish: # Publish an opam description. @ opam publish -v $(DATE) $(THIS) $(ARCHIVE) . # Once the opam package has been published, run [make export]. .PHONY: undo undo: # Undo the last release (assuming it was done on the same date). @ git tag -d $(DATE) @ git push -u origin :$(DATE) monolith-20250314/Makefile.monolith000066400000000000000000000275141476503452400171200ustar00rootroot00000000000000# This Makefile is used by each of the demos. # Let's use a fixed shell. SHELL := bash # The following variables can be overridden via the command line or in a # Makefile that includes this Makefile. # The variable SWITCH must refer to a version of OCaml that has been # compiled with support for afl instrumentation. ifndef SWITCH SWITCH := 4.14.2+afl endif # The variable SEED_SIZE determines the size (in bytes) of the random # data that we use as an initial input. ifndef SEED_SIZE SEED_SIZE := 16 endif # The variable EXE represents the path of the executable file that must # be tested relative to the current directory (the one where [make] is # run). ifndef EXE EXE := Main.exe endif # The variable WHERE is the directory where the input/ and output/ # subdirectories are created. ifndef WHERE WHERE := . endif # dune options. DUNEBUILD := dune build --no-print-directory --display quiet # ---------------------------------------------------------------------------- # Go up to the root of the dune project, and compute the location of the # build subdirectory that corresponds to the current directory. BUILD := $(shell \ up=""; down=""; switch="$(SWITCH)"; \ while ! [ -f dune-project ] ; do \ up="../"$$up ; down=/$$(basename $$(pwd))$$down ; \ cd .. ; \ done ; \ path=$$up"_build/"$${switch-default}$$down ; \ echo $$path \ ) # ---------------------------------------------------------------------------- # [make all] compiles the code in an appropriate opam switch. .PHONY: all all: @(echo "(lang dune 2.0)" && \ echo "(context (opam (switch $(SWITCH))))" \ ) > dune-workspace.afl @ $(DUNEBUILD) --workspace dune-workspace.afl . # ---------------------------------------------------------------------------- # [make setup] creates the required opam switch (if necessary) and installs # Monolith in it (if necessary). .PHONY: setup setup: @ if opam switch list | grep '$(SWITCH) ' >/dev/null ; then \ echo "The switch $(SWITCH) already exists." ; \ else \ echo "Creating switch $(SWITCH)..." ; \ opam switch create $(SWITCH) --no-switch ; \ fi ; \ echo "Installing monolith in the switch $(SWITCH)..." ; \ opam install --yes monolith --switch $(SWITCH) # ---------------------------------------------------------------------------- # [make clean] cleans up. .PHONY: clean clean: @ dune clean @ rm -rf $(INPUT) $(OUTPUT) $(OUTPUT).* @ rm -f dune-workspace.afl # ---------------------------------------------------------------------------- # Settings. # Directories for input and output files. INPUT := $(WHERE)/input OUTPUT := $(WHERE)/output CRASHES := \ $(wildcard $(OUTPUT)/crashes/dummy) \ $(wildcard $(OUTPUT)/crashes/id*) \ $(wildcard $(OUTPUT)/*/crashes/id*) \ # A log file that is written when running in unattended mode. LOG := $(WHERE)/log # This is where dune places the executable file. BINARY := $(BUILD)/$(EXE) # Setting a high stack size limit may be useful or necessary. # For now, we do not do so. # STACK := ulimit -s unlimited STACK := true # ---------------------------------------------------------------------------- # [make prepare] makes preparations for running afl-fuzz. PATTERN := /proc/sys/kernel/core_pattern GOVERNOR := /sys/devices/system/cpu/cpu*/cpufreq/scaling_governor .PHONY: prepare prepare: @ \ case "$$OSTYPE" in \ linux-gnu) \ if grep -v -w --quiet core $(PATTERN) || \ grep -v -w --quiet performance $(GOVERNOR) ; then \ echo "Disabling the crash reporter, and changing CPU settings" ; \ echo "so as to maximize performance." ; \ echo "(This uses sudo; you may be asked for your password.)" ; \ sudo bash -c \ 'echo core >$(PATTERN) && \ (echo performance | tee $(GOVERNOR) >/dev/null)' ; \ fi ;; \ darwin*) \ if launchctl list | grep ReportCrash ; then \ echo "Disabling the crash reporter." ; \ echo "(This uses sudo; you may be asked for your password.)" ; \ SL=/System/Library ; PL=com.apple.ReportCrash ; \ launchctl unload -w $${SL}/LaunchAgents/$${PL}.plist ; \ sudo launchctl unload -w $${SL}/LaunchDaemons/$${PL}.Root.plist ; \ fi ;; \ esac @ rm -rf $(INPUT) $(OUTPUT) @ mkdir -p $(INPUT) $(OUTPUT)/crashes @ dd if=/dev/urandom bs=$(SEED_SIZE) count=1 > $(INPUT)/dummy 2>/dev/null # ---------------------------------------------------------------------------- # [make test] runs afl-fuzz. # afl-fuzz must be interrupted by Ctrl-C after it has found some crashes # (or after it has run long enough). # afl-fuzz refuses to run if the dummy input file $(INPUT)/dummy happens # to cause a crash right away. This is why we run $(BINARY) once before # attempting to launch afl-fuzz. If this initial run fails, then we copy # $(INPUT)/dummy to $(OUTPUT)/crashes, so as to let [make show] and # [make min] work normally. .PHONY: test test: all prepare @ make test_nodep .PHONY: test_nodep test_nodep: @ if $(BINARY) $(INPUT)/dummy ; then \ $(STACK) && afl-fuzz -i $(INPUT) -o $(OUTPUT) $(BINARY) @@ ; \ else \ exitcode=$$? ; \ cp $(INPUT)/dummy $(OUTPUT)/crashes ; \ exit $$exitcode ; \ fi # ---------------------------------------------------------------------------- # [make random] runs random tests (without using afl-fuzz). # When no file name is given, $(BINARY) reads from /dev/urandom. # It runs in an infinite loop and saves the scenarios that it finds # in the directory output/crashes, in a human-readable form. There # is no need to use [make show] to decode them. .PHONY: random random: all prepare @ make random_nodep .PHONY: random_nodep random_nodep: @ $(BINARY) # ---------------------------------------------------------------------------- # [make unattended] runs [make random] # and interrupts it # when MAX failures are found # or when TIMEOUT seconds have elapsed. # It then checks that the outcome is as expected, i.e., some bugs were found, # or no bugs were found, depending on EXPECTING_BUGS (which should be defined # as 0 or 1). # I have observed that (under MacOS) a process that is busy with intensive # input/output will not let itself be killed by [gtimeout]. So we do not # use an external interruption any more; instead we use [--max-scenarios] # and [--timeout] so that Monolith interrupts itself. # To save time, we pass [--show-scenario false]. # We use [--save-scenario true] (this is implicit) # so the scenarios are written to disk # and we can count them (or inspect them) a posteriori. MAX := 10 TIMEOUT := 10 EXPECTING_BUGS := 0 RED = \033[0;31m NORMAL = \033[0m .PHONY: unattended unattended: all @ make unattended_norebuild .PHONY: unattended_norebuild unattended_norebuild: prepare @ echo " $$(pwd)" @ echo " Running unattended for at most $(TIMEOUT) seconds..." @ rm -f $(LOG) @ (($(BINARY) --show-scenario false --max-scenarios $(MAX) --timeout $(TIMEOUT) >$(LOG) 2>&1) || true) \ | grep -v "aborting" || true @ crashes=`ls $(OUTPUT)/crashes | grep -v README | wc -l` && \ if (( $$crashes > 0 )) ; then \ if (( $(EXPECTING_BUGS) > 0 )) ; then \ echo "[OK] Found $$crashes faults, great." ; \ else \ printf "$(RED)[KO] Found $$crashes faults, but none were expected!\n$(NORMAL)" ; \ exit 1 ; \ fi \ else \ if (( $(EXPECTING_BUGS) > 0 )) ; then \ printf "$(RED)[KO] Found no faults in $(TIMEOUT) seconds, yet some were expected!\n$(NORMAL)" ; \ cat $(LOG) ; \ exit 1 ; \ else \ echo "[OK] Found no faults, great." ; \ fi \ fi @ rm -f $(LOG) # ---------------------------------------------------------------------------- # [make multicore] launches several instances of afl-fuzz in parallel. # Therefore, it is usually faster than [make test]. # The following is a hopefully portable way of finding how many cores we have. CORES := $(shell \ nproc 2>/dev/null || \ sysctl -n hw.ncpu 2>/dev/null || \ getconf _NPROCESSORS_ONLN 2>/dev/null || \ echo 1) # Choose a heuristic number of slaves. SLAVES := $(shell expr $(CORES) - 1) .PHONY: check_enough_cores check_enough_cores: @ echo "We have $(CORES) cores." @ if [[ "$(SLAVES)" -le "0" ]]; then \ echo "Not enough cores! Run 'make test' instead."; exit 1; fi .PHONY: multicore multicore: all prepare check_enough_cores # Run one instance in master mode, and many instances in slave mode. # The only difference between masters and slaves is that the master # performs additional deterministic checks. # All processes are launched in the background. @ $(STACK) && \ echo "Launching $(SLAVES) slave instances..." ; \ for i in `seq $(SLAVES)` ; do \ (afl-fuzz -i $(INPUT) -o $(OUTPUT) -S slave$$i $(BINARY) @@ >/dev/null &) ; \ done ; \ echo "Launching one master instance..." ; \ (afl-fuzz -i $(INPUT) -o $(OUTPUT) -M master $(BINARY) @@ >/dev/null &) ; \ # In the foreground, provide periodic progress reports. while true ; do afl-whatsup $(OUTPUT) ; sleep 3 ; done # [make tmux] runs in multicore mode and uses tmux to show all GUIs at # once in a terminal window. (A large window and a small font size are # needed.) # Repeating [tmux select-layout tiled] after every step seems required; # otherwise, tmux can refuse to split a window, arguing that there is # not enough space. .PHONY: tmux tmux: all prepare check_enough_cores @ $(STACK) && \ tmux new-session -s monolith -d "afl-fuzz -i $(INPUT) -o $(OUTPUT) -S master $(BINARY) @@" ; \ tmux select-layout tiled ; \ for i in `seq $(SLAVES)` ; do \ tmux split-window "afl-fuzz -i $(INPUT) -o $(OUTPUT) -S slave$$i $(BINARY) @@" ; \ tmux select-layout tiled ; \ done ; \ tmux select-layout tiled ; \ tmux attach-session .PHONY: whatsup whatsup: afl-whatsup $(OUTPUT) # ---------------------------------------------------------------------------- # [make show] displays the problems found by afl-fuzz in the previous run. .PHONY: show show: @ $(STACK) && \ (for f in $(CRASHES) ; do \ echo "(* $$f *)"; \ tmp=`mktemp /tmp/crash.XXXX` && \ ($(BINARY) $$f > $$tmp 2>&1 || true) >/dev/null 2>&1 ; \ cat $$tmp ; \ rm $$tmp ; \ echo ; \ done) | more # ---------------------------------------------------------------------------- # [make summary] is like [make show], but postprocesses its output so as to # keep only the last instruction before the crash, and sorts these lines, so # as to determine the length of the shortest instruction sequence that causes # a problem. # If you determine that a crash can be obtained in (say) 4 instructions, then # typing [make show] and searching for "@04: Failure" will allow you to # inspect the scenario that caused this crash. .PHONY: summary summary: @ $(STACK) && \ parallel '$(BINARY) {} 2>/dev/null | grep "Failure" | head -n 1' ::: $(CRASHES) \ | sort -r # ---------------------------------------------------------------------------- # [make min] attempts to minimize the problematic inputs found by # afl-fuzz in the previous run. .PHONY: min min: @ COPY=`mktemp -d $(OUTPUT).XXXX` && rm -rf $(COPY) && \ echo "Saving un-minimized output to $$COPY." && \ cp -rf $(OUTPUT) $$COPY @ $(STACK) && \ parallel 'afl-tmin -i {} -o {} -- $(BINARY) @@' ::: $(CRASHES) # ---------------------------------------------------------------------------- # [make unload] turns off the MacOS Crash Reporter utility. # [make load] turns it on again. # This utility should be OFF for afl-fuzz to work correctly. SL := /System/Library PL := com.apple.ReportCrash .PHONY: unload unload: launchctl unload -w $(SL)/LaunchAgents/$(PL).plist sudo launchctl unload -w $(SL)/LaunchDaemons/$(PL).Root.plist .PHONY: load load: launchctl load -w $(SL)/LaunchAgents/$(PL).plist sudo launchctl load -w $(SL)/LaunchDaemons/$(PL).Root.plist # ---------------------------------------------------------------------------- # [make switch] prints the value of SWITCH. .PHONY: switch switch: @ echo $(SWITCH) # [make binary] prints the value of BINARY. .PHONY: binary binary: @ echo $(BINARY) monolith-20250314/README.md000066400000000000000000000157211476503452400151040ustar00rootroot00000000000000# Monolith Monolith offers facilities for **testing an OCaml library** (for instance, a data structure implementation) by **comparing it against a reference implementation**. It can be used to perform either random testing or fuzz testing. Fuzz testing relies on the external tool [`afl-fuzz`](https://lcamtuf.coredump.cx/afl/). The user must describe what types and operations the library provides. Under the best circumstances, this requires **2-3 lines of code per type or operation**. The user must also provide a reference implementation and a candidate implementation of the library. Then, like a monkey typing on a keyboard, Monolith attempts to exercise the library in every possible way, in the hope of discovering a sequence of operations that leads to an unexpected behavior (that is, a situation where the library either raises an unexpected exception or returns an incorrect result). If such a scenario is discovered, it is printed in the form of an OCaml program, so as to help the user reproduce the problem. Monolith assumes that the candidate implementation behaves in a deterministic way. (Without this assumption, one cannot hope to reliably produce a problematic scenario.) It does however allow nondeterministic specifications, that is, situations where the candidate implementation is allowed to behave in several possible ways. ## Installation To install the latest released version, type: ``` opam update opam install monolith ``` To install the latest development version, type: ``` git clone git@gitlab.inria.fr:fpottier/monolith cd monolith opam pin add monolith . ``` ## Documentation The [documentation of the latest released version](http://cambium.inria.fr/~fpottier/monolith/doc/monolith/Monolith/index.html) is available online. The documentation is built locally by `make doc` and can be viewed via `make view`. ## Papers The paper [Strong Automated Testing of OCaml Libraries](http://cambium.inria.fr/~fpottier/publis/pottier-monolith-2021.pdf) by François Pottier describes the use and the design of Monolith in somewhat greater depth than the documentation. ## Demos and Workflow A number of demos are found under `demos/`. The demos under `demos/working` do not have any known bugs, so `make test` should run forever without finding any problem. The demos under `demos/faulty` intentionally contain bugs, so `make test` should very quickly find a number of problems. Some demos require external libraries. Running `make dependencies` once at the top level should install all of the libraries needed by the demos. These demos share a common workflow, which is implemented in [`Makefile.monolith`](Makefile.monolith). This file is installed at the same time as the library. The directory where it resides can be found via the command `ocamlfind query monolith`. First, the external tool `afl-fuzz` must be installed. Here is [a suggested installation script](install-afl-fuzz.sh). Then, an appropriate `opam` switch, such as `4.09.1+afl`, must be created. The name of this switch is controlled by the variable `SWITCH`. This variable can be set by passing something like `SWITCH=4.09.1+afl` on the command line in every `make` invocation, or (better) in a parent `Makefile` which includes `Makefile.monolith`. Creating an `opam` switch is done only once, as follows: ``` make setup # this takes a few minutes ``` If you are using MacOS, you will probably need to disable the system's built-in crash reporter by typing `make unload`. (Otherwise, `afl-fuzz` will complain.) If you are using an antivirus, it is advisable to disable it. As a case in point, Kaspersky Endpoint Security on MacOS imposes a 5x speed penalty when its protection is turned on. After these steps, you are ready to run a demo. In each subdirectory of `demos`, testing is carried out as follows: ``` make test ``` This launches `afl-fuzz`, which keeps running forever, or until it is interrupted by `Ctrl-C`. The number of problematic scenarios (also known as crashes) found by `afl-fuzz` is displayed in red. Once one or more crashes have been found and `afl-fuzz` has been interrupted, it is recommended to first minimize the problem scenarios by using `make min`. Then, you can ask for a report using either `make show` (which produces OCaml code for each crash) or `make summary` (which shows a one-line summary of each crash, by decreasing order of length). A typical workflow is to first use `make summary`, so as to reveal the length of the shortest crash, then type `make show` and search its output (by typing `/`) for the shortest crash. To perform purely random testing, without using `afl-fuzz`, type: ``` make random ``` This uses a single processor core and runs in an infinite loop until a problem is detected. Random testing is significantly faster than fuzz testing, so it may be a good idea to first look for obvious bugs using random testing, then look for nastier bugs using fuzz testing. When running in random mode, after Monolith has a found a scenario, it reduces the amount of fuel and continues searching for a shorter scenario. It is therefore possible to start with a relatively large amount of fuel. ## Parallel Fuzzing The command `make test` launches only one `afl-fuzz` process. Once you are confident that it works, you can instead use `make multicore` or `make tmux`, which launch several processes in parallel. They differ in their user interface: whereas `make multicore` displays only periodic progress reports in the terminal, `make tmux` splits the terminal window using `tmux` and shows the activity of each `afl-fuzz` process in its own pane. These commands launch one master process plus a number of slave processes. The number of slave processes can be adjusted via the command line: for instance, `make SLAVES=1 tmux` uses just one master process and one slave process. While parallel fuzzing is ongoing, typing `make whatsup` displays a progress report. The most interesting line is `Crashes found`, which reports the number of violations found so far. The `Cumulative speed` line is also of interest, but be aware that it seems to take a few minutes for this information to become stable. ## Performance Performance is measured in executions per second. It is visible in the interactive interface, and is also reported by `make whatsup`. Of course, the performance that you can expect depends on the cost of the operations that you are testing. As a single data point, in a version of the `map` demo, on a Linux machine equipped with two eight-core Intel Xeon CPUs (E5-2620 v4 @ 2.10GHz), I am seeing 12k execs/second when using a single `afl-fuzz` process, and about 5k execs/second/core when using all 32 cores in parallel (therefore, about 160k execs/second). Fuzzing under MacOS appears to be about 10 times slower, although I do not know why; I have disabled both the MacOS crash reporter and the antivirus. ## Real-World Applications Monolith has been used to test [Sek](https://gitlab.inria.fr/fpottier/sek/), a library that offers 4 abstract types and well over 100 operations on them. monolith-20250314/TODO.md000066400000000000000000000131151476503452400147070ustar00rootroot00000000000000## To do ### Before the Next Release * `make test` seems to remain stuck forever under Linux, and is slow under MacOS (several tests are unable to succeed before the deadline). Investigate. The safest approach might be to let `make test` perform random testing (without relying on `afl-fuzz`). ### Boring * Write a summary of the point that each demo illustrates. * Grep for `TODO` in `demos/working/map`. ### Short Term * Think about a way of cleaning up at the end of every test scenario (e.g., to close files or database connections). * It would be useful to have two combinators that sort a list: `unsorted` (deconstructible), and `sorted` (constructible). Both would rely on `List.sort`. One unpleasant aspect is that the user would need to pass not only a comparison function, but also an appearance for this function. (And we would build an appearance for the application `List.sort cmp`.) Once this combinator is available, improve the documentation of `iter` and friends to indicate how to test a nondeterministic iteration function. * The functions `use` and `deconstruct` serve roughly the same purpose, which is to construct a context that observes a value. Why is there a distinction between them? `use` runs as long as the spec is "negative" (a concept that is not defined). Can the code be simplified? [A pragmatic reason for the distinction between these functions is that `use` builds an expression context, whereas `deconstruct` builds a pattern. This helps produce idiomatic OCaml code.] If the code cannot be simplified, document why. * Check whether `^!>` really has stricter requirements than `^>`. If so, why? Can this be avoided? Is the documentation correct? Similar questions about `^?>`. * The engine should not call `Arg.parse` by itself; it should let the user do so. (Issue #2.) * `PleaseBackOff` should be tested by a demo. * Use Frédéric's Tag module and see if this has a performance impact. * Proof-read the integer generation functions in `Gen` and check if they are correct and complete. Think about overflows. If possible, remove the restrictive assertions in `semi_open_interval` and `closed_interval`. * Because `deconstruct` is not tail-recursive, deconstructing a large value, such as a long list, can fail with a stack overflow. * If Monolith itself crashes with a `Stack_overflow` exception, or any other exception, then the backtrace is printed to the standard error channel and is not shown by `make show`. * Define a `pick` or `forall` combinator that generates a value and lets the rest of the spec depend on it. * Do something about arrays. If we are talking immutable arrays, then it is good enough to directly declare them as constructible/deconstructible. If we are talking mutable arrays, define `declare_mutable_array` which views arrays as an abstract type equipped with `make/get/set`. * Measure the performance impact of `normalize`, to see whether it is worth fighting to get rid of it. * Move to static checking of (de)constructibility. * If a (sub)pattern does not bind any names and does not cause a failure, then it could be replaced with a wildcard pattern. (Less informative, but possibly much more compact.) ### Longer Term * Think about a unary variant of Monolith where there is no reference implementation and we are trying only to trigger failures in the candidate. * Offer variants of the combinators `^>>` and `%` that give access to the candidate value instead of (or in addition to) the reference value. They are needed when testing a candidate implementation against a trivial reference implementation that does nothing. Write a demo of this method. * In `make random`, after a bug is found, could we reduce the search space to the subset of operations that were used in this scenario? * In `make test`, should we at the beginning offer the fuzzer an opportunity to choose a subset of the operations that should be tested? * Investigate the idea of getting rid of the need for `Tag.equal` by storing the environment, in a decentralized manner, as one list of variable-value pairs per abstract type. * Define a combinator that defines a new type as isomorphic to an existing type. (Use `map_into` and `map_outof` and `ifpol` to convert both ways.) Use it e.g. to define triples. * Introduce a way of declaring that an operation returns a *preexisting* value of an abstract data type. Instead of recording a new dual value in the environment, Monolith would check that this dual value already exists in the environment. Use this feature to specify the `sequence` operation on Sek iterators. * Work on minimizing (shrinking) scenarios. * Try suppressing the recording of a trace (the construction of syntax) and see if this increases performance (under Linux). If so, then recording a trace and printing a scenario should be optional (and would be enabled by `make show` but not by `make test`). * Make it easy to use memoization to manufacture functions that have extensional behavior? Dually, make it easy to verify that a function has extensional behavior (wrap it in a tester that uses memoization). * Think about generating functions, not by generating their code ahead of time, but by simulating their behavior *when they are invoked*. That would allow us to retain the key aspects of our current engine. That said, we would have to work with a goal type, and it is not clear how to achieve the goal, with a limited amount of fuel, and without backtracking (which is not possible, as we cannot undo the side effects of an operation that we have already executed). monolith-20250314/demos/000077500000000000000000000000001476503452400147265ustar00rootroot00000000000000monolith-20250314/demos/.gitignore000066400000000000000000000000441476503452400167140ustar00rootroot00000000000000dune-workspace.afl input output log monolith-20250314/demos/faulty/000077500000000000000000000000001476503452400162325ustar00rootroot00000000000000monolith-20250314/demos/faulty/avl/000077500000000000000000000000001476503452400170145ustar00rootroot00000000000000monolith-20250314/demos/faulty/avl/Candidate.ml000066400000000000000000000121611476503452400212230ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This is an old, faulty version of the AVL tree implementation found in OCaml's standard library. The bug, which violates an internal invariant but does not endanger functional correctness, was discovered by Jean-Christophe Filliâtre while attempting to verify the code. Filliâtre was able to demonstrate the problem by random testing; his tests involved building two sets of up to 10,000 random elements and constructing their union. *) (* https://github.com/ocaml/ocaml/issues/8176 *) (* In my experience, the problem is indeed not difficult to reproduce: among the sequences of [add] and [union] operations of length up to 10,000, many sequences will reveal the problem. *) module Ord = struct type t = int let compare = compare end type elt = Ord.t type t = Empty | Node of t * elt * t * int (* Sets are represented by balanced binary trees (the heights of the children differ by at most 2 *) let height = function Empty -> 0 | Node(_, _, _, h) -> h (* Creates a new node with left son l, value x and right son r. l and r must be balanced and | height l - height r | <= 2. Inline expansion of height for better speed. *) let create l x r = let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1)) (* Same as create, but performs one step of rebalancing if necessary. Assumes l and r balanced. Inline expansion of create for better speed in the most frequent case where no rebalancing is required. *) let bal l x r = let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Set.bal" | Node(ll, lv, lr, _) -> if height ll >= height lr then create ll lv (create lr x r) else begin match lr with Empty -> invalid_arg "Set.bal" | Node(lrl, lrv, lrr, _)-> create (create ll lv lrl) lrv (create lrr x r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Set.bal" | Node(rl, rv, rr, _) -> if height rr >= height rl then create (create l x rl) rv rr else begin match rl with Empty -> invalid_arg "Set.bal" | Node(rll, rlv, rlr, _) -> create (create l x rll) rlv (create rlr rv rr) end end else Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1)) (* Same as bal, but repeat rebalancing until the final result is balanced. *) let rec join l x r = match bal l x r with Empty -> invalid_arg "Set.join" | Node(l', x', r', _) as t' -> let d = height l' - height r' in if d < -2 || d > 2 then join l' x' r' else t' (* Splitting *) let rec split x = function Empty -> (Empty, None, Empty) | Node(l, v, r, _) -> let c = Ord.compare x v in if c = 0 then (l, Some v, r) else if c < 0 then let (ll, vl, rl) = split x l in (ll, vl, join rl v r) else let (lr, vr, rr) = split x r in (join l v lr, vr, rr) (* Implementation of the set operations *) let empty = Empty let rec add x = function Empty -> Node(Empty, x, Empty, 1) | Node(l, v, r, _) as t -> let c = Ord.compare x v in if c = 0 then t else if c < 0 then bal (add x l) v r else bal l v (add x r) let rec union s1 s2 = match (s1, s2) with (Empty, t2) -> t2 | (t1, Empty) -> t1 | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> if h1 >= h2 then if h2 = 1 then add v2 s1 else begin let (l2, _, r2) = split v1 s2 in join (union l1 l2) v1 (union r1 r2) end else if h1 = 1 then add v1 s2 else begin let (l1, _, r1) = split v2 s1 in join (union l1 l2) v2 (union r1 r2) end (* This function, added by Filliâtre, checks whether the AVL invariant is satisfied. *) let rec check = function | Empty -> 0 | Node (l, _, r, h) -> let hl = check l in let hr = check r in assert (h = max hl hr + 1); assert (abs (hl - hr) <= 2); h let check s = ignore (check s) monolith-20250314/demos/faulty/avl/Candidate.mli000066400000000000000000000020661476503452400213770ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) type elt = int type t val empty: t val add: elt -> t -> t val union: t -> t -> t val check: t -> unit monolith-20250314/demos/faulty/avl/Main.ml000066400000000000000000000033221476503452400202320ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Declare the types. *) let element = lt 256 let check (_ : R.t) = C.check, constant "check" let set = declare_abstract_type ~check () (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = set in declare "empty" spec R.empty C.empty; let spec = element ^> set ^> set in declare "add" spec R.add C.add; let spec = set ^> set ^> set in declare "union" spec R.union C.union; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 200 in main fuel monolith-20250314/demos/faulty/avl/Main.mli000066400000000000000000000017631476503452400204120ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/faulty/avl/Makefile000066400000000000000000000007241476503452400204570ustar00rootroot00000000000000# Type [make random] to perform random testing # and [make test] to perform fuzzing (driven by afl-fuzz). # When driven by afl-fuzz, it can take a minute to find a counterexample. When # working in random mode, a counterexample is usually found in a few seconds. # [make random] performs iterated narrowing (that is, it runs forever and # searches for ever-shorter scenarios). include ../../../Makefile.monolith EXPECTING_BUGS := 1 SEED_SIZE := 1000 MODE := random monolith-20250314/demos/faulty/avl/Reference.ml000066400000000000000000000024021476503452400212420ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* We provide a trivial reference implementation. Indeed, in this case, the signature of the unit-under-test is so restricted ([empty], [add], [union], [check]) that there is no way of observing the contents of a set. *) type elt = int type t = unit let empty = () let add _ _ = () let union _ _ = () monolith-20250314/demos/faulty/avl/Reference.mli000066400000000000000000000020401476503452400214110ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) type elt = int type t val empty: t val add: elt -> t -> t val union: t -> t -> t monolith-20250314/demos/faulty/avl/dune000066400000000000000000000001311476503452400176650ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/faulty/bag_det/000077500000000000000000000000001476503452400176175ustar00rootroot00000000000000monolith-20250314/demos/faulty/bag_det/Candidate.ml000066400000000000000000000026131476503452400220270ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A candidate implementation of a bag, based on OCaml's [Queue] module. *) (* Intentional mistake: the reference implementation is LIFO, while the candidate implementation is FIFO, and we have given a deterministic specification, so the system will detect a mismatch. *) type 'a t = 'a Queue.t let create = Queue.create let add = Queue.push let extract bag = if Queue.is_empty bag then None else Some (Queue.pop bag) monolith-20250314/demos/faulty/bag_det/Main.ml000066400000000000000000000041701476503452400210370ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Define [element] as an alias for the concrete type [int]. Equip it with a deterministic generator of fresh elements. There is no point in letting afl-fuzz choose elements in a nondeterministic way; that would be a waste of random bits. *) let element = sequential() (* -------------------------------------------------------------------------- *) (* Declare an abstract type [bag], which is implemented in two different ways by the reference implementation and by the candidate implementation. *) let bag = declare_abstract_type() (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = unit ^> bag in declare "create" spec R.create C.create; let spec = element ^> bag ^> unit in declare "add" spec R.add C.add; let spec = bag ^> option element in declare "extract" spec R.extract C.extract (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/faulty/bag_det/Main.mli000066400000000000000000000017631476503452400212150ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/faulty/bag_det/Makefile000066400000000000000000000000671476503452400212620ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/faulty/bag_det/Reference.ml000066400000000000000000000022101476503452400220420ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of a bag, based on OCaml's [Stack] module. *) type 'a t = 'a Stack.t let create = Stack.create let add = Stack.push let extract = Stack.pop_opt monolith-20250314/demos/faulty/bag_det/dune000066400000000000000000000001311476503452400204700ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/faulty/bag_nondet/000077500000000000000000000000001476503452400203325ustar00rootroot00000000000000monolith-20250314/demos/faulty/bag_nondet/Candidate.ml000066400000000000000000000025661476503452400225510ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A candidate implementation of a bag, based on OCaml's [Queue] module. *) (* Intentional bug: we use [Queue.peek] instead of [Queue.pop], so using [extract] twice returns the same element twice. *) type 'a t = 'a Queue.t let create = Queue.create let add = Queue.push let extract bag = if Queue.is_empty bag then None else Some (Queue.peek bag) let elements bag = List.of_seq (Queue.to_seq bag) monolith-20250314/demos/faulty/bag_nondet/Main.ml000066400000000000000000000070611476503452400215540ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Define [element] as an alias for the concrete type [int]. Equip it with a deterministic generator of fresh elements. There is no point in letting afl-fuzz choose elements in a nondeterministic way; that would be a waste of random bits. *) let element = sequential() (* -------------------------------------------------------------------------- *) (* Declare an abstract type [bag], which is implemented in two different ways by the reference implementation and by the candidate implementation. *) let bag = declare_abstract_type() (* -------------------------------------------------------------------------- *) (* Declare the concrete type [element list] and equip it with a custom notion of equality, which disregards the order of the elements in the list. *) let equal = (fun xs ys -> List.sort compare xs = List.sort compare ys), constant "(fun xs ys -> List.sort compare xs = List.sort compare ys)" let element_set = deconstructible ~equal Print.(list int) (* -------------------------------------------------------------------------- *) (* Declare the operations. *) (* We have a nondeterministic specification: the operation [extract] is allowed to extract an arbitrary element of the bag. The candidate implementation employs a specific strategy (it is FIFO), but the reference implementation must allow any strategy. To express this, we use a [nondet] specification. This means that the operation [R.extract] must have result type [element option -> element option diagnostic] instead of simply [element option]. That is, it has access to the result produced by the candidate and must either 1- accept it and produce its own result or 2- reject it and produce an assertion that explains the problem. *) (* The operation [elements] is also nondeterministic, insofar as the order of the elements in the list is unspecified. We can however view it as a deterministic operation by equipping the concrete type [element list] with a custom notion of equality. *) let () = let spec = unit ^> bag in declare "create" spec R.create C.create; let spec = element ^> bag ^> unit in declare "add" spec R.add C.add; let spec = bag ^?> option element in declare "extract" spec R.extract C.extract; let spec = bag ^> element_set in declare "elements" spec R.elements C.elements; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/faulty/bag_nondet/Main.mli000066400000000000000000000017631476503452400217300ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/faulty/bag_nondet/Makefile000066400000000000000000000000671476503452400217750ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/faulty/bag_nondet/Reference.ml000066400000000000000000000065411476503452400225700ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of a bag, based on a reference to a linked list. *) open PPrint open Monolith open Monolith.Print type 'a t = 'a list ref let create () = ref [] let add x bag = bag := x :: !bag let elements bag = !bag let mem x bag = List.mem x !bag let rec remove x xs = match xs with | [] -> assert false | x' :: xs -> if x = x' then xs else x' :: remove x xs let remove x bag = bag := remove x !bag (* [print_mem o bag] produces code for an OCaml expression of type [bool] which expresses the fact that the variable [o] of type [int option] is equal to [Some c], where [c] ranges over the elements of the bag [bag]. E.g., if the bag contains the elements 1 and 2, then [print_mem "observed" bag] produces the string ["observed = Some 1 || observed = Some 2"]. *) let print_mem (o : document) (xs : int list) : document = flow_map (break 1 ^^ string "||" ^^ space) (fun x -> o ^^ utf8format " = Some %d" x) xs let print_mem o bag = print_mem o !bag let extract (bag : 'a t) (ox : 'a option) : 'a option diagnostic = (* Our mission is to determine whether [ox] is a valid result for the operation [extract bag]. *) match !bag, ox with | [], Some x -> (* The bag is empty, yet the candidate is able to extract an element. Declare that this is invalid, and construct an assertion that states that we expected the candidate to return [None]. *) Invalid (fun o -> assert_ (o ^^ string " = None") ^^ candidate_finds (option int (Some x)) ) | _ :: _, None -> (* The bag is nonempty, yet the candidate returns [None]. *) Invalid (fun o -> assert_ (o ^^ string " <> None") ^^ candidate_finds (string "None") ) | [], None -> Valid ox | _, Some x -> (* The bag is nonempty and the candidate extracts [x]. We must check that [x] is indeed an element of the bag, and remove it, so that the reference and the candidate remain in sync. *) (* To implement this logic, we need the operations [mem] and [remove] to exist in the reference implementation. They need not exist in the candidate implementation. *) if mem x bag then begin remove x bag; Valid ox end else Invalid (fun o -> assert_ (print_mem o bag) ^^ candidate_finds (option int (Some x)) ) monolith-20250314/demos/faulty/bag_nondet/dune000066400000000000000000000001311476503452400212030ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/faulty/generator/000077500000000000000000000000001476503452400202205ustar00rootroot00000000000000monolith-20250314/demos/faulty/generator/Candidate.ml000066400000000000000000000027201476503452400224270ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A candidate implementation of a stateful number generator, whose nondeterministic specification states that the next number must be strictly greater than the previous number. The generator itself is deterministic. *) type t = int ref let create () = ref 0 let next (g : t) = (* Intentional mistake: [!g] will go from 3 back to 0, violating the spec. *) g := (!g + 1) mod 4; !g let check model g = (* We verify that the model's internal state is the same as ours. *) assert (!model = !g) monolith-20250314/demos/faulty/generator/Main.ml000066400000000000000000000033641476503452400214440ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Declare an abstract type [t], which is implemented in two different ways by the reference implementation and by the candidate implementation. *) let check model = C.check model, constant "check" let t = declare_abstract_type ~var:"g" ~check () (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = unit ^> t in declare "create" spec R.create C.create; let spec = t ^?> int in declare "next" spec R.next C.next; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/faulty/generator/Main.mli000066400000000000000000000017631476503452400216160ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/faulty/generator/Makefile000066400000000000000000000000671476503452400216630ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/faulty/generator/Reference.ml000066400000000000000000000043721476503452400224560ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of a stateful nondeterministic number generator, whose specification states that the next number must be strictly greater than the previous number. *) type t = int ref let create () = ref 0 (* Whereas the function [C.next] has type [t -> int], the function [R.next] has type [t -> int -> int diagnostic]. Its arguments are the generator [g] and the candidate result produced by [C.next]. It returns a value of type [int diagnostic] that indicates whether the candidate result is valid or invalid. In the latter case, the diagnostic includes an OCaml assertion that allows reproducing the problem. *) open Monolith open Monolith.Print open PPrint let next (g : t) (candidate : int) : int diagnostic = (* According to the specification, the candidate result [candidate] is acceptable if and only if it is strictly greater than [!g]. *) if !g < candidate then begin (* It is acceptable. Update our internal state. *) g := candidate; Valid candidate end else begin (* It is not acceptable: it should have been strictly greater than [!g]. We produce an OCaml assertion that says so. *) Invalid (fun (x : document) -> assert_ (int !g ^^ string " < " ^^ x) ^^ string ";;" ^^ candidate_finds (int candidate) ) end monolith-20250314/demos/faulty/generator/dune000066400000000000000000000001311476503452400210710ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/faulty/map/000077500000000000000000000000001476503452400170075ustar00rootroot00000000000000monolith-20250314/demos/faulty/map/BrokenPtmap.ml000066400000000000000000000274201476503452400215700ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This is a copy of ptmap.ml, taken from ptmap 2.0.5. Commit is b18f4c325019ed1e4e692ae71cd337621982b482. This copy has been modified by re-introducing the bug discovered by Jan Midtgaard, which is to use a signed comparison instead of unsigned comparison. Search for BUG. *) (**************************************************************************) (* *) (* Copyright (C) Jean-Christophe Filliatre *) (* *) (* This software is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Lesser General Public *) (* License version 2.1, with the special exception on linking *) (* described in file LICENSE. *) (* *) (* This software is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) (* *) (**************************************************************************) (*s Maps of integers implemented as Patricia trees, following Chris Okasaki and Andrew Gill's paper {\em Fast Mergeable Integer Maps} ({\tt\small http://www.cs.columbia.edu/\~{}cdo/papers.html\#ml98maps}). See the documentation of module [Ptset] which is also based on the same data-structure. *) type key = int type 'a t = | Empty | Leaf of int * 'a | Branch of int * int * 'a t * 'a t let empty = Empty let is_empty t = t = Empty let zero_bit k m = (k land m) == 0 let rec mem k = function | Empty -> false | Leaf (j,_) -> k == j | Branch (_, m, l, r) -> mem k (if zero_bit k m then l else r) let rec find k = function | Empty -> raise Not_found | Leaf (j,x) -> if k == j then x else raise Not_found | Branch (_, m, l, r) -> find k (if zero_bit k m then l else r) let find_opt k m = try Some (find k m) with Not_found -> None (* Note: find_first/last have to look in both subtrees as these are little-endian Patricia trees *) let rec find_first_opt f = function | Empty -> None | Leaf (j,x) -> if f j then Some (j,x) else None | Branch (_, _, l, r) -> match find_first_opt f l, find_first_opt f r with | Some (lk,lv) , Some (rk,rv) -> if lk < rk then Some (lk,lv) else Some (rk,rv) | Some v, None | None, Some v -> Some v | None, None -> None let find_first f = function | Empty -> raise Not_found | Leaf (j,x) -> if f j then (j,x) else raise Not_found | Branch (_, _, l, r) -> match find_first_opt f l, find_first_opt f r with | Some (lk,lv) , Some (rk,rv) -> if lk < rk then (lk,lv) else (rk,rv) | Some v, None | None, Some v -> v | None, None -> raise Not_found let rec find_last_opt f = function | Empty -> None | Leaf (j,x) -> if f j then Some (j,x) else None | Branch (_, _, l, r) -> match find_last_opt f l, find_last_opt f r with | Some (lk,lv) , Some (rk,rv) -> if lk > rk then Some (lk,lv) else Some (rk,rv) | Some v, None | None, Some v -> Some v | None, None -> None let find_last f = function | Empty -> raise Not_found | Leaf (j,x) -> if f j then (j,x) else raise Not_found | Branch (_, _, l, r) -> match find_last_opt f l, find_last_opt f r with | Some (lk,lv) , Some (rk,rv) -> if lk > rk then (lk,lv) else (rk,rv) | Some v, None | None, Some v -> v | None, None -> raise Not_found let lowest_bit x = x land (-x) let branching_bit p0 p1 = lowest_bit (p0 lxor p1) let mask p m = p land (m-1) let join (p0,t0,p1,t1) = let m = branching_bit p0 p1 in if zero_bit p0 m then Branch (mask p0 m, m, t0, t1) else Branch (mask p0 m, m, t1, t0) let match_prefix k p m = (mask k m) == p let add k x t = let rec ins = function | Empty -> Leaf (k,x) | Leaf (j,_) as t -> if j == k then Leaf (k,x) else join (k, Leaf (k,x), j, t) | Branch (p,m,t0,t1) as t -> if match_prefix k p m then if zero_bit k m then Branch (p, m, ins t0, t1) else Branch (p, m, t0, ins t1) else join (k, Leaf (k,x), p, t) in ins t let singleton k v = add k v empty let branch = function | (_,_,Empty,t) -> t | (_,_,t,Empty) -> t | (p,m,t0,t1) -> Branch (p,m,t0,t1) let remove k t = let rec rmv = function | Empty -> Empty | Leaf (j,_) as t -> if k == j then Empty else t | Branch (p,m,t0,t1) as t -> if match_prefix k p m then if zero_bit k m then branch (p, m, rmv t0, t1) else branch (p, m, t0, rmv t1) else t in rmv t let rec cardinal = function | Empty -> 0 | Leaf _ -> 1 | Branch (_,_,t0,t1) -> cardinal t0 + cardinal t1 let rec iter f = function | Empty -> () | Leaf (k,x) -> f k x | Branch (_,_,t0,t1) -> iter f t0; iter f t1 let rec map f = function | Empty -> Empty | Leaf (k,x) -> Leaf (k, f x) | Branch (p,m,t0,t1) -> Branch (p, m, map f t0, map f t1) let rec mapi f = function | Empty -> Empty | Leaf (k,x) -> Leaf (k, f k x) | Branch (p,m,t0,t1) -> Branch (p, m, mapi f t0, mapi f t1) let rec fold f s accu = match s with | Empty -> accu | Leaf (k,x) -> f k x accu | Branch (_,_,t0,t1) -> fold f t0 (fold f t1 accu) let rec for_all p = function | Empty -> true | Leaf (k, v) -> p k v | Branch (_,_,t0,t1) -> for_all p t0 && for_all p t1 let rec exists p = function | Empty -> false | Leaf (k, v) -> p k v | Branch (_,_,t0,t1) -> exists p t0 || exists p t1 let rec filter pr = function | Empty -> Empty | Leaf (k, v) as t -> if pr k v then t else Empty | Branch (p,m,t0,t1) -> branch (p, m, filter pr t0, filter pr t1) let rec filter_map pr = function | Empty -> Empty | Leaf (k, v) -> (match pr k v with Some v' -> Leaf (k, v') | None -> Empty) | Branch (p,m,t0,t1) -> branch (p, m, filter_map pr t0, filter_map pr t1) let partition p s = let rec part (t,f as acc) = function | Empty -> acc | Leaf (k, v) -> if p k v then (add k v t, f) else (t, add k v f) | Branch (_,_,t0,t1) -> part (part acc t0) t1 in part (Empty, Empty) s let rec choose = function | Empty -> raise Not_found | Leaf (k, v) -> (k, v) | Branch (_, _, t0, _) -> choose t0 (* we know that [t0] is non-empty *) let rec choose_opt = function | Empty -> None | Leaf (k, v) -> Some (k, v) | Branch (_, _, t0, _) -> choose_opt t0 (* we know that [t0] is non-empty *) let split x m = let coll k v (l, b, r) = if k < x then add k v l, b, r else if k > x then l, b, add k v r else l, Some v, r in fold coll m (empty, None, empty) let rec min_binding = function | Empty -> raise Not_found | Leaf (k, v) -> (k, v) | Branch (_,_,s,t) -> let (ks, _) as bs = min_binding s in let (kt, _) as bt = min_binding t in if ks < kt then bs else bt let rec min_binding_opt = function | Empty -> None | Leaf (k, v) -> Some (k, v) | Branch (_,_,s,t) -> match (min_binding_opt s, min_binding_opt t) with | None, None -> None | None, bt -> bt | bs, None -> bs | (Some (ks, _) as bs), (Some (kt, _) as bt) -> if ks < kt then bs else bt let rec max_binding = function | Empty -> raise Not_found | Leaf (k, v) -> (k, v) | Branch (_,_,s,t) -> let (ks, _) as bs = max_binding s in let (kt, _) as bt = max_binding t in if ks > kt then bs else bt let rec max_binding_opt = function | Empty -> None | Leaf (k, v) -> Some (k, v) | Branch (_,_,s,t) -> match max_binding_opt s, max_binding_opt t with | None, None -> None | None, bt -> bt | bs, None -> bs | (Some (ks, _) as bs), (Some (kt, _) as bt) -> if ks > kt then bs else bt let bindings m = fold (fun k v acc -> (k, v) :: acc) m [] (* we order constructors as Empty < Leaf < Branch *) let compare cmp t1 t2 = let rec compare_aux t1 t2 = match t1,t2 with | Empty, Empty -> 0 | Empty, _ -> -1 | _, Empty -> 1 | Leaf (k1,x1), Leaf (k2,x2) -> let c = compare k1 k2 in if c <> 0 then c else cmp x1 x2 | Leaf _, Branch _ -> -1 | Branch _, Leaf _ -> 1 | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> let c = compare p1 p2 in if c <> 0 then c else let c = compare m1 m2 in if c <> 0 then c else let c = compare_aux l1 l2 in if c <> 0 then c else compare_aux r1 r2 in compare_aux t1 t2 let equal eq t1 t2 = let rec equal_aux t1 t2 = match t1, t2 with | Empty, Empty -> true | Leaf (k1,x1), Leaf (k2,x2) -> k1 = k2 && eq x1 x2 | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> p1 = p2 && m1 = m2 && equal_aux l1 l2 && equal_aux r1 r2 | _ -> false in equal_aux t1 t2 let merge f m1 m2 = let add m k = function None -> m | Some v -> add k v m in (* first consider all bindings in m1 *) let m = fold (fun k1 v1 m -> add m k1 (f k1 (Some v1) (find_opt k1 m2))) m1 empty in (* then bindings in m2 that are not in m1 *) fold (fun k2 v2 m -> if mem k2 m1 then m else add m k2 (f k2 None (Some v2))) m2 m let update x f m = match f (find_opt x m) with | None -> remove x m | Some z -> add x z m (* let unsigned_lt n m = n >= 0 && (m < 0 || n < m) *) let unsigned_lt n m = n < m (* BUG *) let rec union f = function | Empty, t -> t | t, Empty -> t | Leaf (k,v1), t -> update k (function None -> Some v1 | Some v2 -> f k v1 v2) t | t, Leaf (k,v2) -> update k (function None -> Some v2 | Some v1 -> f k v1 v2) t | (Branch (p,m,s0,s1) as s), (Branch (q,n,t0,t1) as t) -> if m == n && match_prefix q p m then (* The trees have the same prefix. Merge the subtrees. *) branch (p, m, union f (s0,t0), union f (s1,t1)) else if unsigned_lt m n && match_prefix q p m then (* [q] contains [p]. Merge [t] with a subtree of [s]. *) if zero_bit q m then branch (p, m, union f (s0,t), s1) else branch (p, m, s0, union f (s1,t)) else if unsigned_lt n m && match_prefix p q n then (* [p] contains [q]. Merge [s] with a subtree of [t]. *) if zero_bit p n then branch (q, n, union f (s,t0), t1) else branch (q, n, t0, union f (s,t1)) else (* The prefixes disagree. *) join (p, s, q, t) let union f s t = union f (s,t) let to_seq m = let rec prepend_seq m s = match m with | Empty -> s | Leaf (k, v) -> fun () -> Seq.Cons((k,v), s) | Branch (_, _, l, r) -> prepend_seq l (prepend_seq r s) in prepend_seq m Seq.empty let to_seq_from k m = let rec prepend_seq m s = match m with | Empty -> s | Leaf (key, v) -> if key >= k then fun () -> Seq.Cons((key,v), s) else s | Branch (_, _, l, r) -> prepend_seq l (prepend_seq r s) in prepend_seq m Seq.empty let add_seq s m = Seq.fold_left (fun m (k, v) -> add k v m) m s let of_seq s = Seq.fold_left (fun m (k, v) -> add k v m) empty s monolith-20250314/demos/faulty/map/Candidate.ml000066400000000000000000000023221476503452400212140ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file defines which candidate implementation of maps is tested. *) include Candidate3 (* Define the type [map]. *) type map = int t (* Define the function [check] to do nothing. *) let check (_reference : Reference.map) (_candidate : map) = () monolith-20250314/demos/faulty/map/Candidate3.ml000066400000000000000000000030321476503452400212760ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A third candidate is a variant of the library ptmap, where the bug discovered by Jan Midtgaard in 2017 has been intentionally re-introduced. *) include BrokenPtmap (* Some boilerplate is required in order to satisfy the signature [S]. *) let union f m1 m2 = union (fun _key v1 v2 -> Some (f v1 v2)) m1 m2 (* Confirm that Midtgaard's bug is present. *) let () = let m1 = add min_int 0 (singleton 0 0) and m2 = add min_int 0 (singleton 1 0) in let m = union (fun _x y -> y) m1 m2 in assert (cardinal m = 4) (* Should be 3 if the bug was absent; is in fact 4. *) monolith-20250314/demos/faulty/map/Candidate3.mli000066400000000000000000000017661476503452400214630ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S with type key = int monolith-20250314/demos/faulty/map/Main.ml000066400000000000000000000074511476503452400202340ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Declare an abstract type [map], which is implemented in two different ways by the reference implementation and by the candidate implementation. *) (* We test this map with integer keys and integer values. *) let check model = C.check model, constant "check" let map = declare_abstract_type ~check () (* -------------------------------------------------------------------------- *) (* Propose several key generators. *) (* [arbitrary_key] produces an arbitrary key within a certain interval. The interval must be reasonably small, otherwise the fuzzer wastes time trying lots of different keys. *) let arbitrary_key = Gen.lt 16 (* [extreme_key] produces the key [min_int] or [max_int]. *) let extreme_key () = if Gen.bool() then min_int else max_int (* [present_key m] produces a key that is present in the map [m]. Its implementation is not efficient, but we will likely be working with very small maps, so this should be acceptable. *) let present_key (m : R.map) () = let n = R.cardinal m in let i = Gen.int n () in let key, _value = List.nth (R.bindings m) i in key (* [key m] combines the above generators. *) let key m () = if Gen.bool() then arbitrary_key() else if Gen.bool() then extreme_key() else present_key m () (* Declare the concrete type [key]. *) let key m = int_within (key m) (* -------------------------------------------------------------------------- *) (* Declare the type [value] as an alias for [int]. *) (* We generate values within a restricted range, because we do not expect that a wide range of values is required in order to expose bugs. *) let value = lt 16 (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = map in declare "empty" spec R.empty C.empty; let spec = rot3 (map ^>> fun m -> key m ^> value ^> map) in declare "add" spec R.add C.add; let spec = key R.empty ^> value ^> map in declare "singleton" spec R.singleton C.singleton; let spec = map ^> map ^> map in let k x _y = x in declare "union (fun x _y -> x)" spec (R.union k) (C.union k); (* We pass the [union] operation a non-commutative function, namely [k], so as to possibly detect a bug where [union] passes the two values in the wrong order to the user function. *) let spec = map ^> int in declare "cardinal" spec R.cardinal C.cardinal; (* [find] can raise [Not_found], so we use the arrow combinator [^!>]. *) let spec = rot2 (map ^>> fun m -> key m ^!> value) in declare "find" spec R.find C.find; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 20 in main fuel monolith-20250314/demos/faulty/map/Main.mli000066400000000000000000000017631476503452400204050ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/faulty/map/Makefile000066400000000000000000000007021476503452400204460ustar00rootroot00000000000000# Type [make random] to perform random testing # and [make test] to perform fuzzing (driven by afl-fuzz). # When driven by afl-fuzz, it can take a minute to find a counterexample. When # working in random mode, a counterexample is usually found in a few seconds. # [make random] performs iterated narrowing (that is, it runs forever and # searches for ever-shorter scenarios). include ../../../Makefile.monolith EXPECTING_BUGS := 1 MODE := random monolith-20250314/demos/faulty/map/Reference.ml000066400000000000000000000024331476503452400212410ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* We use OCaml's Map module, specialized to integer keys and integer values, as a reference implementation. *) include Map.Make(Int) (* Define the type [map]. *) type map = int t (* Some boilerplate is required in order to satisfy the signature [S]. *) let union f m1 m2 = union (fun _key v1 v2 -> Some (f v1 v2)) m1 m2 monolith-20250314/demos/faulty/map/Reference.mli000066400000000000000000000020071476503452400214070ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S with type key = int type map = int t monolith-20250314/demos/faulty/map/Signature.ml000066400000000000000000000055361476503452400213130ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This is roughly a subset of OCaml's standard signature [Map.S]. *) (* The functions that have been removed (because some of our candidate implementations do not provide them) are [min_binding], [max_binding], [min_binding_opt], [max_binding_opt], [split], [partition], [merge], [for_all], [find_first], [find_first_opt], [find_last], [find_last_opt], [to_seq], [to_seq_from], [add_seq], [of_seq]. *) (* The type of [union] has been changed so as to make it less general. Instead of accepting a function of type [key -> 'a -> 'a -> 'a option], it requires a function of type ['a -> 'a -> 'a]. *) (* The declaration of the type [t] has been changed from [+'a t] to ['a t], and the type of [empty] has been changed from ['a t] to [int t], in order to accommodate [BatIMap], which does not satisfy the stronger interface. *) module type S = sig type key type 'a t val empty: int t val is_empty: 'a t -> bool val mem: key -> 'a t -> bool val add: key -> 'a -> 'a t -> 'a t val update: key -> ('a option -> 'a option) -> 'a t -> 'a t val singleton: key -> 'a -> 'a t val remove: key -> 'a t -> 'a t val union: ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val exists: (key -> 'a -> bool) -> 'a t -> bool val filter: (key -> 'a -> bool) -> 'a t -> 'a t val filter_map: (key -> 'a -> 'b option) -> 'a t -> 'b t val cardinal: 'a t -> int val bindings: 'a t -> (key * 'a) list val choose: 'a t -> key * 'a val choose_opt: 'a t -> (key * 'a) option val find: key -> 'a t -> 'a val find_opt: key -> 'a t -> 'a option val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t end monolith-20250314/demos/faulty/map/dune000066400000000000000000000001311476503452400176600ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/faulty/pairs/000077500000000000000000000000001476503452400173505ustar00rootroot00000000000000monolith-20250314/demos/faulty/pairs/Candidate.ml000066400000000000000000000032071476503452400215600ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) type 'a t = 'a list let empty = [] let push (x, xs) = x :: xs let length = List.length let get xs i = assert (0 <= i && i < length xs); List.nth xs i let rec split xs i = if i = 0 then [], xs else match xs with | [] -> invalid_arg "split" | x :: xs -> let front, back = split xs (i - 1) in x :: front, back (* Intentional mistake: split at an incorrect index. This mistake in an operation that returns a pair of abstract data structures is not directly observable; instead, one must deconstruct the pair and try to access one of these data structures in order to cause a fault. *) let split xs i = split xs (length xs - i) monolith-20250314/demos/faulty/pairs/Main.ml000066400000000000000000000050201476503452400205630ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Define [element] as an alias for the concrete type [int]. Equip it with a deterministic generator of fresh elements. There is no point in letting afl-fuzz choose elements in a nondeterministic way; that would be a waste of random bits. *) let element = sequential() (* -------------------------------------------------------------------------- *) (* Define [index s] as an alias for the concrete [int], together with a generator that chooses an index comprised between 0 and the length of the stack [s]. *) let index (s : _ R.t) = lt (R.length s) (* -------------------------------------------------------------------------- *) (* Declare an abstract type [stack], which is implemented in two different ways by the reference implementation and by the candidate implementation. *) let stack = declare_abstract_type() (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = stack in declare "empty" spec R.empty C.empty; let spec = (element *** stack) ^> stack in declare "push" spec R.push C.push; let spec = stack ^>> (fun s -> index s ^> element) in declare "get" spec R.get C.get; let spec = stack ^>> (fun s -> index s ^> stack *** stack) in declare "split" spec R.split C.split (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/faulty/pairs/Main.mli000066400000000000000000000017631476503452400207460ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/faulty/pairs/Makefile000066400000000000000000000000671476503452400210130ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/faulty/pairs/Reference.ml000066400000000000000000000024201476503452400215760ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) type 'a t = 'a list let empty = [] let push (x, xs) = x :: xs let length = List.length let get = List.nth let rec split xs i = if i = 0 then [], xs else match xs with | [] -> invalid_arg "split" | x :: xs -> let front, back = split xs (i - 1) in x :: front, back monolith-20250314/demos/faulty/pairs/dune000066400000000000000000000001311476503452400202210ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/faulty/parray/000077500000000000000000000000001476503452400175305ustar00rootroot00000000000000monolith-20250314/demos/faulty/parray/Candidate.ml000066400000000000000000000021201476503452400217310ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A naive attempt to use normal (mutable) arrays as if they were persistent. *) include Array let set a i x = set a i x; a monolith-20250314/demos/faulty/parray/Candidate.mli000066400000000000000000000017421476503452400221130ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S monolith-20250314/demos/faulty/parray/Main.ml000066400000000000000000000113531476503452400207510ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Define [element] as an alias for the concrete type [int]. Equip it with a deterministic generator of fresh elements. There is no point in letting afl-fuzz choose elements in a nondeterministic way; that would be a waste of random bits. *) let element = sequential() (* -------------------------------------------------------------------------- *) (* Define [element_list], etc. as concrete types. *) let element_list = deconstructible Print.(list int) let index_list = deconstructible Print.(list int) let index_element_list = deconstructible Print.(list (pair int int)) (* -------------------------------------------------------------------------- *) (* Declare an abstract type [array] of persistent arrays. *) let array = declare_abstract_type() (* -------------------------------------------------------------------------- *) (* Define wrappers that allow testing the higher-order functions. *) (* Because we use [constant] rather than [define], the definition of the wrapper won't be printed by Monolith as part of an error scenario. This could easily be fixed, but I don't want to make the code longer. *) (* [wrap_iter] converts [iter] into [to_list]. *) let wrap_iter iter a = let xs = ref [] in iter (fun x -> xs := x :: !xs) a; List.rev !xs let wrap_iter = map_into wrap_iter (wrap_iter, constant "wrap_iter") (* [wrap_iteri] is analogous, but produces a list of index-element pairs. *) let wrap_iteri iteri a = let ixs = ref [] in iteri (fun i x -> ixs := (i, x) :: !ixs) a; List.rev !ixs let wrap_iteri = map_into wrap_iteri (wrap_iteri, constant "wrap_iteri") (* [wrap_fold_left] converts [fold_left] into [rev . to_list]. *) let wrap_fold_left fold_left a = fold_left (fun xs x -> x :: xs) [] a let wrap_fold_left = map_into wrap_fold_left (wrap_fold_left, constant "wrap_fold_left") (* [wrap_fold_right] converts [fold_right] into [to_list]. *) let wrap_fold_right fold_right a = fold_right (fun x xs -> x :: xs) a [] let wrap_fold_right = map_into wrap_fold_right (wrap_fold_right, constant "wrap_fold_right") (* [wrap_init] specializes [init] with a function [f] that records the trace of the calls to [f]. This allows us to check the calls [f 0], [f 1], ... [f (n-1)] are performed in order and only once. *) let wrap_init init n = let is = ref [] in let f i = is := i :: !is; i in let a = init n f in List.rev !is, a let wrap_init = map_into wrap_init (wrap_init, constant "wrap_init") (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = lt 16 ^> element ^> array in declare "make" spec R.make C.make; let spec = wrap_init (lt 16 ^> index_list *** array) in declare "init" spec R.init C.init; let spec = array ^> int in declare "length" spec R.length C.length; let spec = array ^>> fun a -> lt (R.length a) ^> element in declare "get" spec R.get C.get; let spec = array ^>> fun a -> lt (R.length a) ^> element ^> array in declare "set" spec R.set C.set; let spec = array ^> element_list in declare "to_list" spec R.to_list C.to_list; let spec = wrap_iter (array ^> element_list) in declare "iter" spec R.iter C.iter; let spec = wrap_iteri (array ^> index_element_list) in declare "iteri" spec R.iteri C.iteri; let spec = wrap_fold_left (array ^> element_list) in declare "fold_left" spec R.fold_left C.fold_left; let spec = wrap_fold_right (array ^> element_list) in declare "fold_right" spec R.fold_right C.fold_right; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/faulty/parray/Main.mli000066400000000000000000000017631476503452400211260ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/faulty/parray/Makefile000066400000000000000000000000671476503452400211730ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/faulty/parray/Reference.ml000066400000000000000000000021601476503452400217570ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of persistent arrays, based on mutable arrays. *) include Array let set a i x = let a = Array.copy a in Array.set a i x; a monolith-20250314/demos/faulty/parray/Reference.mli000066400000000000000000000017421476503452400221350ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S monolith-20250314/demos/faulty/parray/Signature.ml000066400000000000000000000026701476503452400220300ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* The signature of persistent arrays. *) module type S = sig type 'a t val make : int -> 'a -> 'a t val init : int -> (int -> 'a) -> 'a t val length : 'a t -> int val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t val to_list : 'a t -> 'a list val iter : ('a -> unit) -> 'a t -> unit val iteri : (int -> 'a -> unit) -> 'a t -> unit val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b end monolith-20250314/demos/faulty/parray/dune000066400000000000000000000001311476503452400204010ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/faulty/parray_mini/000077500000000000000000000000001476503452400205445ustar00rootroot00000000000000monolith-20250314/demos/faulty/parray_mini/Candidate.ml000066400000000000000000000021201476503452400227450ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A naive attempt to use normal (mutable) arrays as if they were persistent. *) include Array let set a i x = set a i x; a monolith-20250314/demos/faulty/parray_mini/Candidate.mli000066400000000000000000000017421476503452400231270ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S monolith-20250314/demos/faulty/parray_mini/Main.ml000066400000000000000000000030121476503452400217560ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate let () = (* Specs. *) let array = declare_abstract_type() and element = sequential() and length = lt 16 and index a = lt (R.length a) in (* Declare [make]. *) let spec = length ^> element ^> array in declare "make" spec R.make C.make; (* Declare [get]. *) let spec = array ^>> fun a -> index a ^> element in declare "get" spec R.get C.get; (* Declare [set]. *) let spec = array ^>> fun a -> index a ^> element ^> array in declare "set" spec R.set C.set; (* Run. *) main (* fuel: *) 5 monolith-20250314/demos/faulty/parray_mini/Makefile000066400000000000000000000000671476503452400222070ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/faulty/parray_mini/Reference.ml000066400000000000000000000021601476503452400227730ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of persistent arrays, based on mutable arrays. *) include Array let set a i x = let a = Array.copy a in Array.set a i x; a monolith-20250314/demos/faulty/parray_mini/Reference.mli000066400000000000000000000017421476503452400231510ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S monolith-20250314/demos/faulty/parray_mini/Signature.ml000066400000000000000000000026701476503452400230440ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* The signature of persistent arrays. *) module type S = sig type 'a t val make : int -> 'a -> 'a t val init : int -> (int -> 'a) -> 'a t val length : 'a t -> int val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t val to_list : 'a t -> 'a list val iter : ('a -> unit) -> 'a t -> unit val iteri : (int -> 'a -> unit) -> 'a t -> unit val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b end monolith-20250314/demos/faulty/parray_mini/dune000066400000000000000000000001311476503452400214150ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/faulty/sort/000077500000000000000000000000001476503452400172215ustar00rootroot00000000000000monolith-20250314/demos/faulty/sort/Candidate.ml000066400000000000000000000021721476503452400214310ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A candidate implementation of a list sorting algorithm. *) let sort _compare xs = List.sort compare xs (* Intentional mistake: always sort in ascending order. *) monolith-20250314/demos/faulty/sort/Main.ml000066400000000000000000000035531476503452400204450ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Define [element -> element -> int] as a constructible type, whose generator chooses between two ordering functions, namely [compare] and [flip compare]. *) let ordering = constructible (fun () -> if Gen.bool() then compare, constant "compare" else (fun x y -> compare y x), constant "(fun x y -> compare y x)" ) (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = ordering ^> list ~length:(Gen.lt 8) (lt 32) ^> list int in declare "sort" spec R.sort C.sort (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 1 in (* in this particular case, one operation suffices *) main fuel monolith-20250314/demos/faulty/sort/Main.mli000066400000000000000000000017161476503452400206150ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) monolith-20250314/demos/faulty/sort/Makefile000066400000000000000000000000671476503452400206640ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/faulty/sort/Reference.ml000066400000000000000000000020441476503452400214510ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of a list sorting algorithm. *) let sort = List.sort monolith-20250314/demos/faulty/sort/dune000066400000000000000000000001311476503452400200720ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/faulty/sparray/000077500000000000000000000000001476503452400177135ustar00rootroot00000000000000monolith-20250314/demos/faulty/sparray/Candidate.ml000066400000000000000000000047321476503452400221270ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* We introduce a fault in the [length] function: because its implementation uses [rerootk], it has the side effect of requiring the array to be valid, and of invalidating its descendants. However, according to the reference implementation and to the specification, [length] can be applied to an arbitrary array (even an invalid one), and has no side effect. *) type 'a t = 'a data ref and 'a data = | Array of 'a array | Diff of int * 'a * 'a t let make n v = ref (Array (Array.make n v)) let rec rerootk t k = match !t with | Array _ -> k () | Diff (i, v, t') -> rerootk t' (fun () -> begin match !t' with | Array a as n -> (* let v' = a.(i) in *) a.(i) <- v; t := n (* t' := Diff (i, v', t) *) | Diff _ -> assert false end; k() ) let reroot t = rerootk t (fun () -> ()) let get t i = match !t with | Array a -> a.(i) | Diff _ -> reroot t; begin match !t with Array a -> a.(i) | Diff _ -> assert false end let set t i v = reroot t; match !t with | Array a as n -> let old = a.(i) in if old == v then t else begin a.(i) <- v; let res = ref n in t := Diff (i, old, res); res end | Diff _ -> assert false (* wrappers to apply an impure function from Array to a persistent array *) let impure f t = reroot t; match !t with Array a -> f a | Diff _ -> assert false let length t = impure Array.length t (* wrong! *) let to_list t = impure Array.to_list t monolith-20250314/demos/faulty/sparray/Candidate.mli000066400000000000000000000017421476503452400222760ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S monolith-20250314/demos/faulty/sparray/Main.ml000066400000000000000000000044251476503452400211360ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Define [element] as an alias for the concrete type [int]. Equip it with a deterministic generator of fresh elements. There is no point in letting afl-fuzz choose elements in a nondeterministic way; that would be a waste of random bits. *) let element = sequential() (* -------------------------------------------------------------------------- *) (* Declare an abstract type [array] of persistent arrays. *) let array = declare_abstract_type() (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = lt 16 ^> element ^> array in declare "make" spec R.make C.make; let spec = array ^> int in declare "length" spec R.length C.length; let spec = R.valid % array ^>> fun a -> lt (R.length a) ^> element in declare "get" spec R.get C.get; let spec = R.valid % array ^>> fun a -> lt (R.length a) ^> element ^> array in declare "set" spec R.set C.set; let spec = R.valid % array ^> list element in declare "to_list" spec R.to_list C.to_list; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/faulty/sparray/Main.mli000066400000000000000000000017161476503452400213070ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) monolith-20250314/demos/faulty/sparray/Makefile000066400000000000000000000000671476503452400213560ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/faulty/sparray/Reference.ml000066400000000000000000000052441476503452400221500ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* Time stamps. *) let next_stamp : unit -> int = let next = ref 0 in fun () -> let stamp = !next in next := stamp + 1; stamp (* A reference implementation of semi-persistent arrays (spa). We store the data in a mutable array, which we do not mutate. Every spa also stores a pointer to its parent (if it has one) and a time stamp that indicates when this spa was last accessed. *) type 'a t = { (* The data. *) data: 'a array; (* Our parent. *) parent: 'a t option; (* The time stamp of the last access to this spa. *) mutable last: int; } (* A spa is valid if its time stamp is greater than or equal to (i.e., no older than) its parent's time stamp and its parent is valid as well. *) let rec valid spa = match spa.parent with | None -> true | Some parent -> parent.last <= spa.last && valid parent (* Thus, by writing a new time stamp to [spa.last], we invalidate all of [spa]'s direct and indirect descendants. *) let invalidate_descendants spa = spa.last <- next_stamp() let make n x = let data = Array.make n x and parent = None and last = 0 in { data; parent; last } let length spa = (* [length] does not require [spa] to be valid, and does not invalidate any spa. *) Array.length spa.data let get spa i = assert (valid spa); assert (0 <= i && i < length spa); invalidate_descendants spa; Array.get spa.data i let set spa i x = assert (valid spa); assert (0 <= i && i < length spa); invalidate_descendants spa; let data = Array.copy spa.data in Array.set data i x; let parent = Some spa and last = spa.last in { data; parent; last } let to_list spa = assert (valid spa); invalidate_descendants spa; Array.to_list spa.data monolith-20250314/demos/faulty/sparray/Reference.mli000066400000000000000000000022321476503452400223130ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S (* The reference implementation keeps track at runtime of which semi-persistent arrays are currently valid, and exposes this information to the user. *) val valid: 'a t -> bool monolith-20250314/demos/faulty/sparray/Signature.ml000066400000000000000000000023021476503452400222030ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* The signature of persistent arrays. *) module type S = sig type 'a t val make : int -> 'a -> 'a t val length : 'a t -> int val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t val to_list : 'a t -> 'a list end monolith-20250314/demos/faulty/sparray/dune000066400000000000000000000001311476503452400205640ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/misc/000077500000000000000000000000001476503452400156615ustar00rootroot00000000000000monolith-20250314/demos/misc/choose_and_remove_opt_deterministic/000077500000000000000000000000001476503452400251455ustar00rootroot00000000000000monolith-20250314/demos/misc/choose_and_remove_opt_deterministic/Candidate.ml000066400000000000000000000032611476503452400273550ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* We use OCaml's Map module, specialized to integer keys and integer values, as a reference implementation of maps. *) include Map.Make(Int) (* The operation [choose_and_remove_opt] is supposed to return and remove the minimum key of the map. *) let choose_and_remove_opt m = match min_binding_opt m with | None -> None | Some (k, v) -> (* Intentional bugs: we sometimes return an incorrect key, sometimes an incorrect value, sometimes an incorrect map. *) if k = 7 then Some ((k, v), m) else if k = 13 then Some ((k+1, v), remove k m) else if k = 15 then Some ((k, find (k+1) m), remove k m) else Some ((k, v), remove k m) let check _ _ = () monolith-20250314/demos/misc/choose_and_remove_opt_deterministic/Main.ml000066400000000000000000000047411476503452400263710ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Declare an abstract type [map], which is implemented in two different ways by the reference implementation and by the candidate implementation. *) (* We test this map with integer keys and integer values. *) let check model = C.check model, constant "check" let map = declare_abstract_type ~check () (* -------------------------------------------------------------------------- *) (* Declare the type [key] as an alias for [int]. *) let key = lt 16 (* -------------------------------------------------------------------------- *) (* Declare the type [value] as an alias for [int]. *) (* We generate values within a restricted range, because we do not expect that a wide range of values is required in order to expose bugs. *) let value = lt 16 (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = map in declare "empty" spec R.empty C.empty; let spec = key ^> map ^> bool in if false then declare "mem" spec R.mem C.mem; let spec = key ^> value ^> map ^> map in declare "add" spec R.add C.add; let spec = map ^> option ((key *** value) *** map) in declare "choose_and_remove_opt" spec R.choose_and_remove_opt C.choose_and_remove_opt; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/choose_and_remove_opt_deterministic/Main.mli000066400000000000000000000017631476503452400265430ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/misc/choose_and_remove_opt_deterministic/Makefile000066400000000000000000000000671476503452400266100ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/choose_and_remove_opt_deterministic/Reference.ml000066400000000000000000000025251476503452400274010ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* We use OCaml's Map module, specialized to integer keys and integer values, as a reference implementation of maps. *) include Map.Make(Int) (* The operation [choose_and_remove_opt] is supposed to return and remove the minimum key of the map. *) let choose_and_remove_opt m = match min_binding_opt m with | None -> None | Some (k, v) -> Some ((k, v), remove k m) monolith-20250314/demos/misc/choose_and_remove_opt_deterministic/dune000066400000000000000000000001311476503452400260160ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/misc/construct_option/000077500000000000000000000000001476503452400212755ustar00rootroot00000000000000monolith-20250314/demos/misc/construct_option/Candidate.ml000066400000000000000000000022001476503452400234750ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* An operation that computes the cardinal of an option. *) let cardinal = function | None -> 0 | Some v -> (* Intentional bug: *) if v = 3 then -1 else 1 monolith-20250314/demos/misc/construct_option/Main.ml000066400000000000000000000025531476503452400225200ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Declare our operation. *) let () = let spec = option (lt 16) ^> int in declare "cardinal" spec R.cardinal C.cardinal (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/construct_option/Makefile000066400000000000000000000000671476503452400227400ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/construct_option/Reference.ml000066400000000000000000000021151476503452400235240ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* An operation that computes the cardinal of an option. *) let cardinal = function | None -> 0 | Some _ -> 1 monolith-20250314/demos/misc/construct_option/dune000066400000000000000000000001311476503452400221460ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/misc/error_in_wrapper_map_into/000077500000000000000000000000001476503452400231265ustar00rootroot00000000000000monolith-20250314/demos/misc/error_in_wrapper_map_into/Candidate.ml000066400000000000000000000020551476503452400253360ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* An operation that creates a list of length [n]. *) let init n = List.init n (fun i -> i) monolith-20250314/demos/misc/error_in_wrapper_map_into/Main.ml000066400000000000000000000032171476503452400243470ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* This wrapper maps a list to its first element. *) (* It fails if the list is empty. This is a mistake in the wrapper that the system should detect. *) let hd spec = map_into List.hd (List.hd, constant "List.hd") spec (* -------------------------------------------------------------------------- *) (* Declare our operation. *) let () = let spec = lt 16 ^> hd int in declare "init" spec R.init C.init (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/error_in_wrapper_map_into/Makefile000066400000000000000000000000671476503452400245710ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/error_in_wrapper_map_into/Reference.ml000066400000000000000000000020551476503452400253600ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* An operation that creates a list of length [n]. *) let init n = List.init n (fun i -> i) monolith-20250314/demos/misc/error_in_wrapper_map_into/dune000066400000000000000000000001311476503452400237770ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/misc/error_in_wrapper_map_outof/000077500000000000000000000000001476503452400233115ustar00rootroot00000000000000monolith-20250314/demos/misc/error_in_wrapper_map_outof/Main.ml000066400000000000000000000034451476503452400245350ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith (* -------------------------------------------------------------------------- *) (* This wrapper maps an integer to a list of integers. *) (* It fails if the integer is negative. This is a mistake in the wrapper that the system should detect. *) let expand n = List.init n (fun i -> i) let () = dprintf "let expand n = List.init n (fun i -> i);;\n" let appearance = constant "expand" let expand spec = map_outof expand (expand, appearance) spec (* -------------------------------------------------------------------------- *) (* Declare our operation. *) let () = let spec = expand (semi_open_interval (-16) 16) ^> int in declare "length" spec List.length List.length (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/error_in_wrapper_map_outof/Makefile000066400000000000000000000000671476503452400247540ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/error_in_wrapper_map_outof/dune000066400000000000000000000001311476503452400241620ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/misc/exception/000077500000000000000000000000001476503452400176575ustar00rootroot00000000000000monolith-20250314/demos/misc/exception/Candidate.ml000066400000000000000000000036761476503452400221010ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A candidate implementation of a bounded stack, based on an array. *) type 'a t = { data: 'a array; mutable top: int } let create n d = let data = Array.make n d and top = 0 in { data; top } let push x stack = if stack.top = Array.length stack.data then invalid_arg "push" else begin stack.data.(stack.top) <- x; stack.top <- stack.top + 1 end exception Empty let pop stack = (* WRONG: forget to test if stack is empty. *) stack.top <- stack.top - 1; stack.data.(stack.top) let check (model : 'a Reference.t) stack = (* Check that the stack seems well-formed. *) assert (0 <= stack.top); assert (stack.top <= Array.length stack.data); (* Check (partially) that the stack conforms to its model. *) assert (stack.top = Reference.length model) let is_empty stack = stack.top = 0 let is_full stack = stack.top = Array.length stack.data let length stack = stack.top let get stack i = assert (0 <= i && i < stack.top); stack.data.(stack.top - 1 - i) monolith-20250314/demos/misc/exception/Main.ml000066400000000000000000000072601476503452400211020ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Define [element] as an alias for the concrete type [int]. Equip it with a deterministic generator of fresh elements. There is no point in letting afl-fuzz choose elements in a nondeterministic way; that would be a waste of random bits. *) let element = sequential() (* -------------------------------------------------------------------------- *) (* Define [length] as an alias for the concrete type [int]. Equip it with a nondeterministic generator that chooses a length comprised between 0 and some fixed maximum length. *) let maximum_length = 1024 let length = le maximum_length (* -------------------------------------------------------------------------- *) (* Define [index s] as an alias for the concrete [int], together with a generator that chooses an index comprised between 0 and the length of the stack [s]. *) let index (s : _ R.t) = lt (R.length s) (* -------------------------------------------------------------------------- *) (* Declare an abstract type [stack], which is implemented in two different ways by the reference implementation and by the candidate implementation. *) let check model = C.check model, constant "check" let stack = declare_abstract_type ~check () (* -------------------------------------------------------------------------- *) (* The following functions are used in the preconditions of some operations. They are expressed in terms of the reference implementation. *) let nonfull stack = not (R.is_full stack) (* -------------------------------------------------------------------------- *) (* Declare that the exceptions [R.Empty] and [C.Empty] are related. *) let () = override_exn_eq (fun (=) e1 e2 -> match e1, e2 with | R.Empty, C.Empty -> true | _, _ -> e1 = e2 ) (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = length ^> element ^> stack in declare "create" spec R.create C.create; let spec = element ^> (nonfull % stack) ^> unit in declare "push" spec R.push C.push; let spec = stack ^!> element in declare "pop" spec R.pop C.pop; let spec = stack ^> bool in declare "is_empty" spec R.is_empty C.is_empty; let spec = stack ^> bool in declare "is_full" spec R.is_full C.is_full; let spec = stack ^> int in declare "length" spec R.length C.length; let spec = stack ^>> (fun s -> index s ^> element) in declare "get" spec R.get C.get (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/exception/Main.mli000066400000000000000000000017631476503452400212550ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/misc/exception/Makefile000066400000000000000000000000671476503452400213220ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/exception/Reference.ml000066400000000000000000000051301476503452400221060ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of a bounded stack, based on OCaml's [Stack] module. *) (* [create] records the bound [n] chosen by the client, because we need it in order to be able to test whether the stack is full. Regardless of whether this test is or is not part of the library's API, we have to implement it here, because it appears in the precondition of [push], and the reference implementation must be able to test at runtime whether a precondition holds. *) (* [push] does not check whether the stack overflows. It is the client's responsibility to not push more than [n] elements onto the stack. *) (* [pop] does not check whether the stack is empty. It is the client's responsibility to not attempt to pop an element off an empty stack. *) type 'a t = { stack: 'a Stack.t; n: int } let create n _d = { stack = Stack.create(); n } let push x s = Stack.push x s.stack exception Empty = Stack.Empty let pop s = Stack.pop s.stack let length s = Stack.length s.stack let is_empty s = Stack.is_empty s.stack let is_full s = length s = s.n (* [get i s] fetches the stack element whose index is [i]. The index 0 refers to the most-recently-pushed elements. *) let get s i = (* This is inefficient. Also, it's somewhat nonstandard for a stack to offer a [get] operation. We don't really care. This is just a demo, and I need an example of an operation that has a dependent specification. *) let rec get i xs = match i, xs() with | _, Seq.Nil -> invalid_arg "get" | 0, Seq.Cons (x, _) -> x | _, Seq.Cons (_, xs) -> get (i - 1) xs in get i (Stack.to_seq s.stack) monolith-20250314/demos/misc/exception/dune000066400000000000000000000001311476503452400205300ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/misc/map_choose/000077500000000000000000000000001476503452400177765ustar00rootroot00000000000000monolith-20250314/demos/misc/map_choose/Candidate.ml000066400000000000000000000026741476503452400222150ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file defines which candidate implementation of maps is tested. *) include Candidate2 (* Define the type [map]. *) type map = int t (* Define the function [check] to do nothing. *) let check (_reference : Reference.map) (_candidate : map) = () (* An intentional bug in [choose]. *) let choose m = match choose m with | (14, v) -> (14, v+1) | (11, v) -> (12, v) | (7, _) -> failwith "Empty" (* raise the wrong exception! *) | result -> result monolith-20250314/demos/misc/map_choose/Candidate2.ml000066400000000000000000000022351476503452400222700ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A second candidate is the library ptmap. *) include Ptmap (* Some boilerplate is required in order to satisfy the signature [S]. *) let union f m1 m2 = union (fun _key v1 v2 -> Some (f v1 v2)) m1 m2 monolith-20250314/demos/misc/map_choose/Candidate2.mli000066400000000000000000000017661476503452400224510ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S with type key = int monolith-20250314/demos/misc/map_choose/Main.ml000066400000000000000000000067131476503452400212230ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A scaled-down version of demos/working/map, with an intentional bug in the candidate implementation of [choose_opt]. *) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Declare an abstract type [map], which is implemented in two different ways by the reference implementation and by the candidate implementation. *) (* We test this map with integer keys and integer values. *) let check model = C.check model, constant "check" let map = declare_abstract_type ~check () (* -------------------------------------------------------------------------- *) (* Propose several key generators. *) (* [arbitrary_key] produces an arbitrary key within a certain interval. The interval must be reasonably small, otherwise the fuzzer wastes time trying lots of different keys. *) let arbitrary_key = Gen.lt 16 (* [extreme_key] produces the key [min_int] or [max_int]. *) let extreme_key () = if Gen.bool() then min_int else max_int (* [present_key m] produces a key that is present in the map [m]. Its implementation is not efficient, but we will likely be working with very small maps, so this should be acceptable. *) let present_key (m : R.map) () = let n = R.cardinal m in let i = Gen.int n () in let key, _value = List.nth (R.bindings m) i in key (* [key m] combines the above generators. *) let key m () = if Gen.bool() then arbitrary_key() else if Gen.bool() then extreme_key() else present_key m () (* Declare the concrete type [key]. *) let key m = int_within (key m) (* -------------------------------------------------------------------------- *) (* Declare the type [value] as an alias for [int]. *) (* We generate values within a restricted range, because we do not expect that a wide range of values is required in order to expose bugs. *) let value = lt 16 (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = map in declare "empty" spec R.empty C.empty; let spec = rot3 (map ^>> fun m -> key m ^> value ^> map) in declare "add" spec R.add C.add; (* [choose] is interesting: its specification is nondeterministic and it can raise [Not_found]. *) let spec = map ^!?> int *** value in declare "choose" spec R.choose C.choose; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/map_choose/Main.mli000066400000000000000000000017631476503452400213740ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/misc/map_choose/Makefile000066400000000000000000000000671476503452400214410ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/map_choose/Reference.ml000066400000000000000000000065341476503452400222360ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* We use OCaml's Map module, specialized to integer keys and integer values, as a reference implementation. *) include Map.Make(Int) (* Define the type [map]. *) type map = int t (* Some boilerplate is required in order to satisfy the signature [S]. *) let union f m1 m2 = union (fun _key v1 v2 -> Some (f v1 v2)) m1 m2 (* [choose_opt] is nondeterministic. *) open Monolith open Monolith.Print let string, (^^), utf8format = PPrint.(string, (^^), utf8format) let expected_some_result () = (* The map is nonempty, yet the candidate returned nothing. *) Invalid (fun observed -> assert_ (observed ^^ string " <> None") ^^ comment (string "The map is supposed to be nonempty.") (* If desired, we could print a list of the keys which we expect to exist in the map. *) ) let nonexistent_key k = (* The key [k] does not exist in the map. *) Invalid (fun _ -> comment (utf8format "The key %d is not supposed to exist in the map." k)) let incorrect_value k rv cv = Invalid (fun _ -> comment (utf8format "The key %d is supposed to be associated with %d, not %d." k rv cv)) let candidate_has_returned candidate m k cv = match find_opt k m with | None -> nonexistent_key k | Some rv -> if rv = cv then Valid candidate else incorrect_value k rv cv let choose_opt (m : int t) (candidate : (key * int) option) : (key * int) option diagnostic = match is_empty m, candidate with | false, None -> expected_some_result() | true, None -> Valid candidate | _, Some (k, cv) -> candidate_has_returned candidate m k cv (* [choose] is nondeterministic. *) (* We could avoid code duplication simply by testing [C.choose] indirectly: wrap it so that it has the same type as [C.choose_opt], then test it exactly like [C.choose_opt]. Here, as an exercise, we give a direct reference implementation for [choose_opt]. *) let choose (m : int t) (candidate : (key * int, exn) result) : (key * int, exn) result diagnostic = match is_empty m, candidate with | false, Error Not_found -> expected_some_result() | true, Error Not_found -> Valid candidate | _, Error e -> (* The candidate has raised some exception other than [Not_found]. *) Invalid (fun _ -> comment (utf8format "Candidate has raised %s." (Printexc.to_string e))) | _, Ok (k, cv) -> candidate_has_returned candidate m k cv monolith-20250314/demos/misc/map_choose/Reference.mli000066400000000000000000000024511476503452400224010ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S with type key = int type map = int t (* [choose] and [choose_opt] are nondeterministic. *) (* They is specialized to integer keys and values because this allows us to print better diagnostic messages. *) open Monolith val choose: int t -> (int * int, exn) result nondet val choose_opt: int t -> (int * int) option nondet monolith-20250314/demos/misc/map_choose/Signature.ml000066400000000000000000000055361476503452400223020ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This is roughly a subset of OCaml's standard signature [Map.S]. *) (* The functions that have been removed (because some of our candidate implementations do not provide them) are [min_binding], [max_binding], [min_binding_opt], [max_binding_opt], [split], [partition], [merge], [for_all], [find_first], [find_first_opt], [find_last], [find_last_opt], [to_seq], [to_seq_from], [add_seq], [of_seq]. *) (* The type of [union] has been changed so as to make it less general. Instead of accepting a function of type [key -> 'a -> 'a -> 'a option], it requires a function of type ['a -> 'a -> 'a]. *) (* The declaration of the type [t] has been changed from [+'a t] to ['a t], and the type of [empty] has been changed from ['a t] to [int t], in order to accommodate [BatIMap], which does not satisfy the stronger interface. *) module type S = sig type key type 'a t val empty: int t val is_empty: 'a t -> bool val mem: key -> 'a t -> bool val add: key -> 'a -> 'a t -> 'a t val update: key -> ('a option -> 'a option) -> 'a t -> 'a t val singleton: key -> 'a -> 'a t val remove: key -> 'a t -> 'a t val union: ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val exists: (key -> 'a -> bool) -> 'a t -> bool val filter: (key -> 'a -> bool) -> 'a t -> 'a t val filter_map: (key -> 'a -> 'b option) -> 'a t -> 'b t val cardinal: 'a t -> int val bindings: 'a t -> (key * 'a) list val choose: 'a t -> key * 'a val choose_opt: 'a t -> (key * 'a) option val find: key -> 'a t -> 'a val find_opt: key -> 'a t -> 'a option val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t end monolith-20250314/demos/misc/map_choose/dune000066400000000000000000000001371476503452400206550ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith ptmap) ) monolith-20250314/demos/misc/map_choose_opt/000077500000000000000000000000001476503452400206605ustar00rootroot00000000000000monolith-20250314/demos/misc/map_choose_opt/Candidate.ml000066400000000000000000000026521476503452400230730ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file defines which candidate implementation of maps is tested. *) include Candidate2 (* Define the type [map]. *) type map = int t (* Define the function [check] to do nothing. *) let check (_reference : Reference.map) (_candidate : map) = () (* An intentional bug in [choose_opt]. *) let choose_opt m = let result = choose_opt m in match result with | Some (14, v) -> Some (14, v+1) | Some (11, v) -> Some (12, v) | _ -> result monolith-20250314/demos/misc/map_choose_opt/Candidate2.ml000066400000000000000000000022351476503452400231520ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A second candidate is the library ptmap. *) include Ptmap (* Some boilerplate is required in order to satisfy the signature [S]. *) let union f m1 m2 = union (fun _key v1 v2 -> Some (f v1 v2)) m1 m2 monolith-20250314/demos/misc/map_choose_opt/Candidate2.mli000066400000000000000000000017661476503452400233330ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S with type key = int monolith-20250314/demos/misc/map_choose_opt/Main.ml000066400000000000000000000067011476503452400221020ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A scaled-down version of demos/working/map, with an intentional bug in the candidate implementation of [choose_opt]. *) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Declare an abstract type [map], which is implemented in two different ways by the reference implementation and by the candidate implementation. *) (* We test this map with integer keys and integer values. *) let check model = C.check model, constant "check" let map = declare_abstract_type ~check () (* -------------------------------------------------------------------------- *) (* Propose several key generators. *) (* [arbitrary_key] produces an arbitrary key within a certain interval. The interval must be reasonably small, otherwise the fuzzer wastes time trying lots of different keys. *) let arbitrary_key = Gen.lt 16 (* [extreme_key] produces the key [min_int] or [max_int]. *) let extreme_key () = if Gen.bool() then min_int else max_int (* [present_key m] produces a key that is present in the map [m]. Its implementation is not efficient, but we will likely be working with very small maps, so this should be acceptable. *) let present_key (m : R.map) () = let n = R.cardinal m in let i = Gen.int n () in let key, _value = List.nth (R.bindings m) i in key (* [key m] combines the above generators. *) let key m () = if Gen.bool() then arbitrary_key() else if Gen.bool() then extreme_key() else present_key m () (* Declare the concrete type [key]. *) let key m = int_within (key m) (* -------------------------------------------------------------------------- *) (* Declare the type [value] as an alias for [int]. *) (* We generate values within a restricted range, because we do not expect that a wide range of values is required in order to expose bugs. *) let value = lt 16 (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = map in declare "empty" spec R.empty C.empty; let spec = rot3 (map ^>> fun m -> key m ^> value ^> map) in declare "add" spec R.add C.add; (* [choose_opt] is interesting: its specification is nondeterministic. *) let spec = map ^?> option (int *** value) in declare "choose_opt" spec R.choose_opt C.choose_opt; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/map_choose_opt/Main.mli000066400000000000000000000017631476503452400222560ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/misc/map_choose_opt/Makefile000066400000000000000000000000671476503452400223230ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/map_choose_opt/Reference.ml000066400000000000000000000046111476503452400231120ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* We use OCaml's Map module, specialized to integer keys and integer values, as a reference implementation. *) include Map.Make(Int) (* Define the type [map]. *) type map = int t (* Some boilerplate is required in order to satisfy the signature [S]. *) let union f m1 m2 = union (fun _key v1 v2 -> Some (f v1 v2)) m1 m2 (* [choose_opt] is nondeterministic. *) open Monolith open Monolith.Print let string, (^^), utf8format = PPrint.(string, (^^), utf8format) let choose_opt (m : int t) (candidate : (key * int) option) : (key * int) option diagnostic = match is_empty m, candidate with | false, None -> (* The map is nonempty, yet the candidate returned nothing. *) Invalid (fun observed -> assert_ (observed ^^ string " <> None") ^^ comment (string "The map is supposed to be nonempty.") (* If desired, we could print a list of the keys which we expect to exist in the map. *) ) | true, None -> Valid candidate | _, Some (k, v) -> match find_opt k m with | None -> (* The key [k] does not exist in the map. *) Invalid (fun _ -> comment (utf8format "The key %d is not supposed to exist in the map." k)) | Some v' -> if v = v' then Valid candidate else Invalid (fun _ -> comment (utf8format "The key %d is supposed to be associated with %d, not %d." k v' v)) monolith-20250314/demos/misc/map_choose_opt/Reference.mli000066400000000000000000000023451476503452400232650ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S with type key = int type map = int t (* [choose_opt] is nondeterministic. *) (* It is specialized to integer keys and values because this allows us to print better diagnostic messages. *) open Monolith val choose_opt: int t -> (int * int) option nondet monolith-20250314/demos/misc/map_choose_opt/Signature.ml000066400000000000000000000055361476503452400231640ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This is roughly a subset of OCaml's standard signature [Map.S]. *) (* The functions that have been removed (because some of our candidate implementations do not provide them) are [min_binding], [max_binding], [min_binding_opt], [max_binding_opt], [split], [partition], [merge], [for_all], [find_first], [find_first_opt], [find_last], [find_last_opt], [to_seq], [to_seq_from], [add_seq], [of_seq]. *) (* The type of [union] has been changed so as to make it less general. Instead of accepting a function of type [key -> 'a -> 'a -> 'a option], it requires a function of type ['a -> 'a -> 'a]. *) (* The declaration of the type [t] has been changed from [+'a t] to ['a t], and the type of [empty] has been changed from ['a t] to [int t], in order to accommodate [BatIMap], which does not satisfy the stronger interface. *) module type S = sig type key type 'a t val empty: int t val is_empty: 'a t -> bool val mem: key -> 'a t -> bool val add: key -> 'a -> 'a t -> 'a t val update: key -> ('a option -> 'a option) -> 'a t -> 'a t val singleton: key -> 'a -> 'a t val remove: key -> 'a t -> 'a t val union: ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val exists: (key -> 'a -> bool) -> 'a t -> bool val filter: (key -> 'a -> bool) -> 'a t -> 'a t val filter_map: (key -> 'a -> 'b option) -> 'a t -> 'b t val cardinal: 'a t -> int val bindings: 'a t -> (key * 'a) list val choose: 'a t -> key * 'a val choose_opt: 'a t -> (key * 'a) option val find: key -> 'a t -> 'a val find_opt: key -> 'a t -> 'a option val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t end monolith-20250314/demos/misc/map_choose_opt/dune000066400000000000000000000001371476503452400215370ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith ptmap) ) monolith-20250314/demos/misc/memoize_simple/000077500000000000000000000000001476503452400206775ustar00rootroot00000000000000monolith-20250314/demos/misc/memoize_simple/Candidate.ml000066400000000000000000000020741476503452400231100ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A candidate implementation of memoization at type [int -> 'a]. *) let memoize = Fix.Memoize.Int.memoize monolith-20250314/demos/misc/memoize_simple/Main.ml000066400000000000000000000033711476503452400221210ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Define a way of generating functions of type [int -> int]. *) let int2int = constructible (fun () -> if Gen.bool() then (fun x -> 2 * x + 1), constant "(fun x -> 2 * x + 1)" else (fun x -> 47 - x), constant "(fun x -> 47 - x)" ) (* -------------------------------------------------------------------------- *) (* Declare our operation. *) let () = let memoized = declare_semi_abstract_type (lt 16 ^> int) in let spec = int2int ^> memoized in declare "memoize" spec R.memoize C.memoize (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/memoize_simple/Main.mli000066400000000000000000000017631476503452400222750ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/misc/memoize_simple/Makefile000066400000000000000000000000431476503452400223340ustar00rootroot00000000000000include ../../../Makefile.monolith monolith-20250314/demos/misc/memoize_simple/Reference.ml000066400000000000000000000021661476503452400231340ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of memoization at type [int -> 'a]. *) (* This implementation is correct if the function that is memoized is pure. *) let memoize f = f monolith-20250314/demos/misc/memoize_simple/dune000066400000000000000000000001351476503452400215540ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith fix) ) monolith-20250314/demos/misc/nondet_under_pair_left/000077500000000000000000000000001476503452400223725ustar00rootroot00000000000000monolith-20250314/demos/misc/nondet_under_pair_left/Candidate.ml000066400000000000000000000023461476503452400246050ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A candidate implementation of a nondeterministic operation that is supposed to return a pair of an even number and an odd number. *) (* Intentional mistake: the implementation returns two odd numbers. *) let f i = if i = 13 then 129, 133 else 2 * i, 2 * i + 1 monolith-20250314/demos/misc/nondet_under_pair_left/Main.ml000066400000000000000000000025431476503452400236140ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Declare our operation. *) let () = let spec = lt 16 ^> nondet int *** nondet int in declare "f" spec R.f C.f (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/nondet_under_pair_left/Makefile000066400000000000000000000000671476503452400240350ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/nondet_under_pair_left/Reference.ml000066400000000000000000000031301476503452400246170ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of a nondeterministic operation that is supposed to return a pair of an even number and an odd number. *) open Monolith open Monolith.Print open PPrint let must_have_parity (parity : int) (candidate : int) : int diagnostic = if candidate mod 2 <> parity then Invalid (fun observed -> assert_ (observed ^^ utf8format " mod 2 = %d" parity) ^^ string ";;" ^^ candidate_finds (int candidate) ) else Valid candidate let must_be_even : int -> int diagnostic = must_have_parity 0 let must_be_odd : int -> int diagnostic = must_have_parity 1 let f (_ : int) = must_be_even, must_be_odd monolith-20250314/demos/misc/nondet_under_pair_left/dune000066400000000000000000000001311476503452400232430ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/misc/nondet_under_pair_right/000077500000000000000000000000001476503452400225555ustar00rootroot00000000000000monolith-20250314/demos/misc/nondet_under_pair_right/Candidate.ml000066400000000000000000000023461476503452400247700ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A candidate implementation of a nondeterministic operation that is supposed to return a pair of an even number and an odd number. *) (* Intentional mistake: the implementation returns two even numbers. *) let f i = if i = 7 then 128, 128 else 2 * i, 2 * i + 1 monolith-20250314/demos/misc/nondet_under_pair_right/Main.ml000066400000000000000000000025431476503452400237770ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Declare our operation. *) let () = let spec = lt 16 ^> nondet int *** nondet int in declare "f" spec R.f C.f (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/nondet_under_pair_right/Makefile000066400000000000000000000000671476503452400242200ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/nondet_under_pair_right/Reference.ml000066400000000000000000000031301476503452400250020ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of a nondeterministic operation that is supposed to return a pair of an even number and an odd number. *) open Monolith open Monolith.Print open PPrint let must_have_parity (parity : int) (candidate : int) : int diagnostic = if candidate mod 2 <> parity then Invalid (fun observed -> assert_ (observed ^^ utf8format " mod 2 = %d" parity) ^^ string ";;" ^^ candidate_finds (int candidate) ) else Valid candidate let must_be_even : int -> int diagnostic = must_have_parity 0 let must_be_odd : int -> int diagnostic = must_have_parity 1 let f (_ : int) = must_be_even, must_be_odd monolith-20250314/demos/misc/nondet_under_pair_right/dune000066400000000000000000000001311476503452400234260ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/misc/seq1/000077500000000000000000000000001476503452400165325ustar00rootroot00000000000000monolith-20250314/demos/misc/seq1/Candidate.ml000066400000000000000000000022221476503452400207360ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* An unbounded queue. *) include Queue (* A faulty variant of [to_seq], which returns a truncated sequence, keeping only the first two elements. *) let to_seq q = CCSeq.take 2 (to_seq q) monolith-20250314/demos/misc/seq1/Main.ml000066400000000000000000000027741476503452400177620ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate let element = sequential() let stack = declare_abstract_type() let seq = declare_seq (lt 16) let nonempty s = not (R.is_empty s) let () = let spec = element ^> stack ^> unit in declare "push" spec R.push C.push; let spec = nonempty % stack ^> element in declare "pop" spec R.pop C.pop; let spec = seq ^> stack in declare "of_seq" spec R.of_seq C.of_seq; let spec = stack ^> seq in declare "to_seq" spec R.to_seq C.to_seq; () let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/seq1/Main.mli000066400000000000000000000017631476503452400201300ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/misc/seq1/Makefile000066400000000000000000000001231476503452400201660ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 MODE := random TIMEOUT := 5 monolith-20250314/demos/misc/seq1/Reference.ml000066400000000000000000000017671476503452400207750ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* An unbounded queue. *) include Queue monolith-20250314/demos/misc/seq1/dune000066400000000000000000000001441476503452400174070ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith containers) ) monolith-20250314/demos/misc/seq2/000077500000000000000000000000001476503452400165335ustar00rootroot00000000000000monolith-20250314/demos/misc/seq2/Candidate.ml000066400000000000000000000022161476503452400207420ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* An unbounded queue. *) include Queue (* A faulty variant of [of_seq], which truncates the sequence, keeping only the first two elements. *) let of_seq xs = of_seq (CCSeq.take 2 xs) monolith-20250314/demos/misc/seq2/Main.ml000066400000000000000000000027741476503452400177630ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate let element = sequential() let stack = declare_abstract_type() let seq = declare_seq (lt 16) let nonempty s = not (R.is_empty s) let () = let spec = element ^> stack ^> unit in declare "push" spec R.push C.push; let spec = nonempty % stack ^> element in declare "pop" spec R.pop C.pop; let spec = seq ^> stack in declare "of_seq" spec R.of_seq C.of_seq; let spec = stack ^> seq in declare "to_seq" spec R.to_seq C.to_seq; () let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/seq2/Main.mli000066400000000000000000000017631476503452400201310ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/misc/seq2/Makefile000066400000000000000000000000671476503452400201760ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/seq2/Reference.ml000066400000000000000000000017671476503452400207760ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* An unbounded queue. *) include Queue monolith-20250314/demos/misc/seq2/dune000066400000000000000000000001441476503452400174100ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith containers) ) monolith-20250314/demos/misc/seq3/000077500000000000000000000000001476503452400165345ustar00rootroot00000000000000monolith-20250314/demos/misc/seq3/Candidate.ml000066400000000000000000000022511476503452400207420ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* An unbounded queue. *) include Queue (* A faulty variant of [to_seq], which returns a correct sequence, which can unfortunately be consumed only once. *) let to_seq q = Monolith.Support.Seq.affine (to_seq q) monolith-20250314/demos/misc/seq3/Main.ml000066400000000000000000000027741476503452400177640ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate let element = sequential() let stack = declare_abstract_type() let seq = declare_seq (lt 16) let nonempty s = not (R.is_empty s) let () = let spec = element ^> stack ^> unit in declare "push" spec R.push C.push; let spec = nonempty % stack ^> element in declare "pop" spec R.pop C.pop; let spec = seq ^> stack in declare "of_seq" spec R.of_seq C.of_seq; let spec = stack ^> seq in declare "to_seq" spec R.to_seq C.to_seq; () let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/seq3/Main.mli000066400000000000000000000017631476503452400201320ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/misc/seq3/Makefile000066400000000000000000000000671476503452400201770ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/seq3/Reference.ml000066400000000000000000000017671476503452400207770ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* An unbounded queue. *) include Queue monolith-20250314/demos/misc/seq3/dune000066400000000000000000000001311476503452400174050ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/misc/seq4/000077500000000000000000000000001476503452400165355ustar00rootroot00000000000000monolith-20250314/demos/misc/seq4/Candidate.ml000066400000000000000000000026431476503452400207500ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* Converting a sequence to an array. *) (* This implementation consumes the sequence twice. *) let rec length xs = match xs() with | Seq.Nil -> 0 | Seq.Cons (_, xs) -> 1 + length xs let iterator xs = let c = ref xs in fun () -> match xs() with | Seq.Nil -> assert false | Seq.Cons (x, xs) -> c := xs; x let to_array xs = let n = length xs in let next = iterator xs in Array.init n (fun _i -> next()) monolith-20250314/demos/misc/seq4/Main.ml000066400000000000000000000026251476503452400177600ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate let aseq = declare_affine_seq (lt 16) let array = declare_abstract_type() let () = let spec = aseq ^> array in declare "to_array" spec R.to_array C.to_array; (* This should fail, since [C.to_array] consumes its argument twice, which it is not allowed to do, since we have described this argument as an affine sequence. *) () let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/seq4/Main.mli000066400000000000000000000017631476503452400201330ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/misc/seq4/Makefile000066400000000000000000000000671476503452400202000ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/seq4/Reference.ml000066400000000000000000000017541476503452400207740ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) let to_array = Array.of_seq monolith-20250314/demos/misc/seq4/dune000066400000000000000000000001311476503452400174060ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/misc/seq5/000077500000000000000000000000001476503452400165365ustar00rootroot00000000000000monolith-20250314/demos/misc/seq5/Candidate.ml000066400000000000000000000023141476503452400207440ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* Converting an array to an affine sequence. *) let to_seq a = let n = Array.length a in let i = ref 0 in let rec next () = if !i < n then let x = a.(!i) in i := !i + 1; Seq.Cons (x, next) else Seq.Nil in next monolith-20250314/demos/misc/seq5/Main.ml000066400000000000000000000031171476503452400177560ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate let element = lt 16 let aseq = declare_affine_seq element let array = declare_abstract_type() let () = let spec = list element ^> array in declare "init" spec Array.of_list Array.of_list; (* A way of creating arrays. *) let spec = array ^> aseq in declare "to_seq" spec R.to_seq C.to_seq; (* Testing [to_seq]. This test succeeds because we have declared the result affine. It would fail if we had declared it to be a persistent sequence, because [C.to_seq] produces an affine sequence. *) () let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/seq5/Main.mli000066400000000000000000000017631476503452400201340ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/misc/seq5/Makefile000066400000000000000000000000431476503452400201730ustar00rootroot00000000000000include ../../../Makefile.monolith monolith-20250314/demos/misc/seq5/Reference.ml000066400000000000000000000017521476503452400207730ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) let to_seq = Array.to_seq monolith-20250314/demos/misc/seq5/dune000066400000000000000000000001311476503452400174070ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/misc/seq6/000077500000000000000000000000001476503452400165375ustar00rootroot00000000000000monolith-20250314/demos/misc/seq6/Candidate.ml000066400000000000000000000023451476503452400207510ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* Converting an array to an affine sequence. *) let to_seq a = let n = Array.length a in let i = ref 1 in (* wrong: off by one! *) let rec next () = if !i < n then let x = a.(!i) in i := !i + 1; Seq.Cons (x, next) else Seq.Nil in next monolith-20250314/demos/misc/seq6/Main.ml000066400000000000000000000031171476503452400177570ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate let element = lt 16 let aseq = declare_affine_seq element let array = declare_abstract_type() let () = let spec = list element ^> array in declare "init" spec Array.of_list Array.of_list; (* A way of creating arrays. *) let spec = array ^> aseq in declare "to_seq" spec R.to_seq C.to_seq; (* Testing [to_seq]. This test succeeds because we have declared the result affine. It would fail if we had declared it to be a persistent sequence, because [C.to_seq] produces an affine sequence. *) () let () = let fuel = 5 in main fuel monolith-20250314/demos/misc/seq6/Main.mli000066400000000000000000000017631476503452400201350ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/misc/seq6/Makefile000066400000000000000000000000671476503452400202020ustar00rootroot00000000000000include ../../../Makefile.monolith EXPECTING_BUGS := 1 monolith-20250314/demos/misc/seq6/Reference.ml000066400000000000000000000017521476503452400207740ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) let to_seq = Array.to_seq monolith-20250314/demos/misc/seq6/dune000066400000000000000000000001311476503452400174100ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/working/000077500000000000000000000000001476503452400164065ustar00rootroot00000000000000monolith-20250314/demos/working/bag/000077500000000000000000000000001476503452400171375ustar00rootroot00000000000000monolith-20250314/demos/working/bag/Candidate.ml000066400000000000000000000023651476503452400213530ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A candidate implementation of a bag, based on OCaml's [Queue] module. *) type 'a t = 'a Queue.t let create = Queue.create let add = Queue.push let extract bag = if Queue.is_empty bag then None else Some (Queue.pop bag) let elements bag = List.of_seq (Queue.to_seq bag) monolith-20250314/demos/working/bag/Main.ml000066400000000000000000000070611476503452400203610ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Define [element] as an alias for the concrete type [int]. Equip it with a deterministic generator of fresh elements. There is no point in letting afl-fuzz choose elements in a nondeterministic way; that would be a waste of random bits. *) let element = sequential() (* -------------------------------------------------------------------------- *) (* Declare an abstract type [bag], which is implemented in two different ways by the reference implementation and by the candidate implementation. *) let bag = declare_abstract_type() (* -------------------------------------------------------------------------- *) (* Declare the concrete type [element list] and equip it with a custom notion of equality, which disregards the order of the elements in the list. *) let equal = (fun xs ys -> List.sort compare xs = List.sort compare ys), constant "(fun xs ys -> List.sort compare xs = List.sort compare ys)" let element_set = deconstructible ~equal Print.(list int) (* -------------------------------------------------------------------------- *) (* Declare the operations. *) (* We have a nondeterministic specification: the operation [extract] is allowed to extract an arbitrary element of the bag. The candidate implementation employs a specific strategy (it is FIFO), but the reference implementation must allow any strategy. To express this, we use a [nondet] specification. This means that the operation [R.extract] must have result type [element option -> element option diagnostic] instead of simply [element option]. That is, it has access to the result produced by the candidate and must either 1- accept it and produce its own result or 2- reject it and produce an assertion that explains the problem. *) (* The operation [elements] is also nondeterministic, insofar as the order of the elements in the list is unspecified. We can however view it as a deterministic operation by equipping the concrete type [element list] with a custom notion of equality. *) let () = let spec = unit ^> bag in declare "create" spec R.create C.create; let spec = element ^> bag ^> unit in declare "add" spec R.add C.add; let spec = bag ^?> option element in declare "extract" spec R.extract C.extract; let spec = bag ^> element_set in declare "elements" spec R.elements C.elements; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/working/bag/Main.mli000066400000000000000000000017161476503452400205330ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) monolith-20250314/demos/working/bag/Makefile000066400000000000000000000000431476503452400205740ustar00rootroot00000000000000include ../../../Makefile.monolith monolith-20250314/demos/working/bag/Reference.ml000066400000000000000000000065411476503452400213750ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of a bag, based on a reference to a linked list. *) open PPrint open Monolith open Monolith.Print type 'a t = 'a list ref let create () = ref [] let add x bag = bag := x :: !bag let elements bag = !bag let mem x bag = List.mem x !bag let rec remove x xs = match xs with | [] -> assert false | x' :: xs -> if x = x' then xs else x' :: remove x xs let remove x bag = bag := remove x !bag (* [print_mem o bag] produces code for an OCaml expression of type [bool] which expresses the fact that the variable [o] of type [int option] is equal to [Some c], where [c] ranges over the elements of the bag [bag]. E.g., if the bag contains the elements 1 and 2, then [print_mem "observed" bag] produces the string ["observed = Some 1 || observed = Some 2"]. *) let print_mem (o : document) (xs : int list) : document = flow_map (break 1 ^^ string "||" ^^ space) (fun x -> o ^^ utf8format " = Some %d" x) xs let print_mem o bag = print_mem o !bag let extract (bag : 'a t) (ox : 'a option) : 'a option diagnostic = (* Our mission is to determine whether [ox] is a valid result for the operation [extract bag]. *) match !bag, ox with | [], Some x -> (* The bag is empty, yet the candidate is able to extract an element. Declare that this is invalid, and construct an assertion that states that we expected the candidate to return [None]. *) Invalid (fun o -> assert_ (o ^^ string " = None") ^^ candidate_finds (option int (Some x)) ) | _ :: _, None -> (* The bag is nonempty, yet the candidate returns [None]. *) Invalid (fun o -> assert_ (o ^^ string " <> None") ^^ candidate_finds (string "None") ) | [], None -> Valid ox | _, Some x -> (* The bag is nonempty and the candidate extracts [x]. We must check that [x] is indeed an element of the bag, and remove it, so that the reference and the candidate remain in sync. *) (* To implement this logic, we need the operations [mem] and [remove] to exist in the reference implementation. They need not exist in the candidate implementation. *) if mem x bag then begin remove x bag; Valid ox end else Invalid (fun o -> assert_ (print_mem o bag) ^^ candidate_finds (option int (Some x)) ) monolith-20250314/demos/working/bag/dune000066400000000000000000000001311476503452400200100ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/working/map/000077500000000000000000000000001476503452400171635ustar00rootroot00000000000000monolith-20250314/demos/working/map/BrokenPtmap.ml000066400000000000000000000274201476503452400217440ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This is a copy of ptmap.ml, taken from ptmap 2.0.5. Commit is b18f4c325019ed1e4e692ae71cd337621982b482. This copy has been modified by re-introducing the bug discovered by Jan Midtgaard, which is to use a signed comparison instead of unsigned comparison. Search for BUG. *) (**************************************************************************) (* *) (* Copyright (C) Jean-Christophe Filliatre *) (* *) (* This software is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Lesser General Public *) (* License version 2.1, with the special exception on linking *) (* described in file LICENSE. *) (* *) (* This software is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) (* *) (**************************************************************************) (*s Maps of integers implemented as Patricia trees, following Chris Okasaki and Andrew Gill's paper {\em Fast Mergeable Integer Maps} ({\tt\small http://www.cs.columbia.edu/\~{}cdo/papers.html\#ml98maps}). See the documentation of module [Ptset] which is also based on the same data-structure. *) type key = int type 'a t = | Empty | Leaf of int * 'a | Branch of int * int * 'a t * 'a t let empty = Empty let is_empty t = t = Empty let zero_bit k m = (k land m) == 0 let rec mem k = function | Empty -> false | Leaf (j,_) -> k == j | Branch (_, m, l, r) -> mem k (if zero_bit k m then l else r) let rec find k = function | Empty -> raise Not_found | Leaf (j,x) -> if k == j then x else raise Not_found | Branch (_, m, l, r) -> find k (if zero_bit k m then l else r) let find_opt k m = try Some (find k m) with Not_found -> None (* Note: find_first/last have to look in both subtrees as these are little-endian Patricia trees *) let rec find_first_opt f = function | Empty -> None | Leaf (j,x) -> if f j then Some (j,x) else None | Branch (_, _, l, r) -> match find_first_opt f l, find_first_opt f r with | Some (lk,lv) , Some (rk,rv) -> if lk < rk then Some (lk,lv) else Some (rk,rv) | Some v, None | None, Some v -> Some v | None, None -> None let find_first f = function | Empty -> raise Not_found | Leaf (j,x) -> if f j then (j,x) else raise Not_found | Branch (_, _, l, r) -> match find_first_opt f l, find_first_opt f r with | Some (lk,lv) , Some (rk,rv) -> if lk < rk then (lk,lv) else (rk,rv) | Some v, None | None, Some v -> v | None, None -> raise Not_found let rec find_last_opt f = function | Empty -> None | Leaf (j,x) -> if f j then Some (j,x) else None | Branch (_, _, l, r) -> match find_last_opt f l, find_last_opt f r with | Some (lk,lv) , Some (rk,rv) -> if lk > rk then Some (lk,lv) else Some (rk,rv) | Some v, None | None, Some v -> Some v | None, None -> None let find_last f = function | Empty -> raise Not_found | Leaf (j,x) -> if f j then (j,x) else raise Not_found | Branch (_, _, l, r) -> match find_last_opt f l, find_last_opt f r with | Some (lk,lv) , Some (rk,rv) -> if lk > rk then (lk,lv) else (rk,rv) | Some v, None | None, Some v -> v | None, None -> raise Not_found let lowest_bit x = x land (-x) let branching_bit p0 p1 = lowest_bit (p0 lxor p1) let mask p m = p land (m-1) let join (p0,t0,p1,t1) = let m = branching_bit p0 p1 in if zero_bit p0 m then Branch (mask p0 m, m, t0, t1) else Branch (mask p0 m, m, t1, t0) let match_prefix k p m = (mask k m) == p let add k x t = let rec ins = function | Empty -> Leaf (k,x) | Leaf (j,_) as t -> if j == k then Leaf (k,x) else join (k, Leaf (k,x), j, t) | Branch (p,m,t0,t1) as t -> if match_prefix k p m then if zero_bit k m then Branch (p, m, ins t0, t1) else Branch (p, m, t0, ins t1) else join (k, Leaf (k,x), p, t) in ins t let singleton k v = add k v empty let branch = function | (_,_,Empty,t) -> t | (_,_,t,Empty) -> t | (p,m,t0,t1) -> Branch (p,m,t0,t1) let remove k t = let rec rmv = function | Empty -> Empty | Leaf (j,_) as t -> if k == j then Empty else t | Branch (p,m,t0,t1) as t -> if match_prefix k p m then if zero_bit k m then branch (p, m, rmv t0, t1) else branch (p, m, t0, rmv t1) else t in rmv t let rec cardinal = function | Empty -> 0 | Leaf _ -> 1 | Branch (_,_,t0,t1) -> cardinal t0 + cardinal t1 let rec iter f = function | Empty -> () | Leaf (k,x) -> f k x | Branch (_,_,t0,t1) -> iter f t0; iter f t1 let rec map f = function | Empty -> Empty | Leaf (k,x) -> Leaf (k, f x) | Branch (p,m,t0,t1) -> Branch (p, m, map f t0, map f t1) let rec mapi f = function | Empty -> Empty | Leaf (k,x) -> Leaf (k, f k x) | Branch (p,m,t0,t1) -> Branch (p, m, mapi f t0, mapi f t1) let rec fold f s accu = match s with | Empty -> accu | Leaf (k,x) -> f k x accu | Branch (_,_,t0,t1) -> fold f t0 (fold f t1 accu) let rec for_all p = function | Empty -> true | Leaf (k, v) -> p k v | Branch (_,_,t0,t1) -> for_all p t0 && for_all p t1 let rec exists p = function | Empty -> false | Leaf (k, v) -> p k v | Branch (_,_,t0,t1) -> exists p t0 || exists p t1 let rec filter pr = function | Empty -> Empty | Leaf (k, v) as t -> if pr k v then t else Empty | Branch (p,m,t0,t1) -> branch (p, m, filter pr t0, filter pr t1) let rec filter_map pr = function | Empty -> Empty | Leaf (k, v) -> (match pr k v with Some v' -> Leaf (k, v') | None -> Empty) | Branch (p,m,t0,t1) -> branch (p, m, filter_map pr t0, filter_map pr t1) let partition p s = let rec part (t,f as acc) = function | Empty -> acc | Leaf (k, v) -> if p k v then (add k v t, f) else (t, add k v f) | Branch (_,_,t0,t1) -> part (part acc t0) t1 in part (Empty, Empty) s let rec choose = function | Empty -> raise Not_found | Leaf (k, v) -> (k, v) | Branch (_, _, t0, _) -> choose t0 (* we know that [t0] is non-empty *) let rec choose_opt = function | Empty -> None | Leaf (k, v) -> Some (k, v) | Branch (_, _, t0, _) -> choose_opt t0 (* we know that [t0] is non-empty *) let split x m = let coll k v (l, b, r) = if k < x then add k v l, b, r else if k > x then l, b, add k v r else l, Some v, r in fold coll m (empty, None, empty) let rec min_binding = function | Empty -> raise Not_found | Leaf (k, v) -> (k, v) | Branch (_,_,s,t) -> let (ks, _) as bs = min_binding s in let (kt, _) as bt = min_binding t in if ks < kt then bs else bt let rec min_binding_opt = function | Empty -> None | Leaf (k, v) -> Some (k, v) | Branch (_,_,s,t) -> match (min_binding_opt s, min_binding_opt t) with | None, None -> None | None, bt -> bt | bs, None -> bs | (Some (ks, _) as bs), (Some (kt, _) as bt) -> if ks < kt then bs else bt let rec max_binding = function | Empty -> raise Not_found | Leaf (k, v) -> (k, v) | Branch (_,_,s,t) -> let (ks, _) as bs = max_binding s in let (kt, _) as bt = max_binding t in if ks > kt then bs else bt let rec max_binding_opt = function | Empty -> None | Leaf (k, v) -> Some (k, v) | Branch (_,_,s,t) -> match max_binding_opt s, max_binding_opt t with | None, None -> None | None, bt -> bt | bs, None -> bs | (Some (ks, _) as bs), (Some (kt, _) as bt) -> if ks > kt then bs else bt let bindings m = fold (fun k v acc -> (k, v) :: acc) m [] (* we order constructors as Empty < Leaf < Branch *) let compare cmp t1 t2 = let rec compare_aux t1 t2 = match t1,t2 with | Empty, Empty -> 0 | Empty, _ -> -1 | _, Empty -> 1 | Leaf (k1,x1), Leaf (k2,x2) -> let c = compare k1 k2 in if c <> 0 then c else cmp x1 x2 | Leaf _, Branch _ -> -1 | Branch _, Leaf _ -> 1 | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> let c = compare p1 p2 in if c <> 0 then c else let c = compare m1 m2 in if c <> 0 then c else let c = compare_aux l1 l2 in if c <> 0 then c else compare_aux r1 r2 in compare_aux t1 t2 let equal eq t1 t2 = let rec equal_aux t1 t2 = match t1, t2 with | Empty, Empty -> true | Leaf (k1,x1), Leaf (k2,x2) -> k1 = k2 && eq x1 x2 | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> p1 = p2 && m1 = m2 && equal_aux l1 l2 && equal_aux r1 r2 | _ -> false in equal_aux t1 t2 let merge f m1 m2 = let add m k = function None -> m | Some v -> add k v m in (* first consider all bindings in m1 *) let m = fold (fun k1 v1 m -> add m k1 (f k1 (Some v1) (find_opt k1 m2))) m1 empty in (* then bindings in m2 that are not in m1 *) fold (fun k2 v2 m -> if mem k2 m1 then m else add m k2 (f k2 None (Some v2))) m2 m let update x f m = match f (find_opt x m) with | None -> remove x m | Some z -> add x z m (* let unsigned_lt n m = n >= 0 && (m < 0 || n < m) *) let unsigned_lt n m = n < m (* BUG *) let rec union f = function | Empty, t -> t | t, Empty -> t | Leaf (k,v1), t -> update k (function None -> Some v1 | Some v2 -> f k v1 v2) t | t, Leaf (k,v2) -> update k (function None -> Some v2 | Some v1 -> f k v1 v2) t | (Branch (p,m,s0,s1) as s), (Branch (q,n,t0,t1) as t) -> if m == n && match_prefix q p m then (* The trees have the same prefix. Merge the subtrees. *) branch (p, m, union f (s0,t0), union f (s1,t1)) else if unsigned_lt m n && match_prefix q p m then (* [q] contains [p]. Merge [t] with a subtree of [s]. *) if zero_bit q m then branch (p, m, union f (s0,t), s1) else branch (p, m, s0, union f (s1,t)) else if unsigned_lt n m && match_prefix p q n then (* [p] contains [q]. Merge [s] with a subtree of [t]. *) if zero_bit p n then branch (q, n, union f (s,t0), t1) else branch (q, n, t0, union f (s,t1)) else (* The prefixes disagree. *) join (p, s, q, t) let union f s t = union f (s,t) let to_seq m = let rec prepend_seq m s = match m with | Empty -> s | Leaf (k, v) -> fun () -> Seq.Cons((k,v), s) | Branch (_, _, l, r) -> prepend_seq l (prepend_seq r s) in prepend_seq m Seq.empty let to_seq_from k m = let rec prepend_seq m s = match m with | Empty -> s | Leaf (key, v) -> if key >= k then fun () -> Seq.Cons((key,v), s) else s | Branch (_, _, l, r) -> prepend_seq l (prepend_seq r s) in prepend_seq m Seq.empty let add_seq s m = Seq.fold_left (fun m (k, v) -> add k v m) m s let of_seq s = Seq.fold_left (fun m (k, v) -> add k v m) empty s monolith-20250314/demos/working/map/Candidate.ml000066400000000000000000000023221476503452400213700ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file defines which candidate implementation of maps is tested. *) include Candidate2 (* Define the type [map]. *) type map = int t (* Define the function [check] to do nothing. *) let check (_reference : Reference.map) (_candidate : map) = () monolith-20250314/demos/working/map/Candidate1.ml000066400000000000000000000027641476503452400214630ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* One possible candidate is CCIntMap, provided by the library containers-data. *) include CCIntMap (* Some boilerplate is required in order to satisfy the signature [S]. *) type key = int let compare cmp m1 m2 = compare ~cmp m1 m2 let equal eq m1 m2 = equal ~eq m1 m2 let union f m1 m2 = union (fun _key v1 v2 -> f v1 v2) m1 m2 let find, find_opt = find_exn, find let choose, choose_opt = choose_exn, choose let bindings m = ignore m; raise Monolith.Unimplemented let exists f m = ignore (f, m); raise Monolith.Unimplemented monolith-20250314/demos/working/map/Candidate1.mli000066400000000000000000000017661476503452400216350ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S with type key = int monolith-20250314/demos/working/map/Candidate2.ml000066400000000000000000000022351476503452400214550ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A second candidate is the library ptmap. *) include Ptmap (* Some boilerplate is required in order to satisfy the signature [S]. *) let union f m1 m2 = union (fun _key v1 v2 -> Some (f v1 v2)) m1 m2 monolith-20250314/demos/working/map/Candidate2.mli000066400000000000000000000017661476503452400216360ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S with type key = int monolith-20250314/demos/working/map/Candidate4.ml000066400000000000000000000024771476503452400214670ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* The splay trees provided by Batteries Included. *) include BatSplay.Map(Int) let update = modify_opt (* batteries >= 2.1 *) let union f m1 m2 = merge (fun _key ov1 ov2 -> match ov1, ov2 with | None, ov | ov, None -> ov | Some v1, Some v2 -> Some (f v1 v2) ) m1 m2 let choose_opt m = ignore m; raise Monolith.Unimplemented monolith-20250314/demos/working/map/Candidate4.mli000066400000000000000000000017661476503452400216400ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S with type key = int monolith-20250314/demos/working/map/Candidate5.ml000066400000000000000000000035411476503452400214610ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* The diet trees provided by Batteries Included. *) include BatIMap let empty = empty ~eq:(=) let singleton k v = singleton ~eq:(=) k v let update = modify_opt (* batteries >= 2.1 *) let compare cmp m1 m2 = ignore (cmp, m1, m2); raise Monolith.Unimplemented let equal eq m1 m2 = ignore (eq, m1, m2); raise Monolith.Unimplemented let exists f m = ignore (f, m); raise Monolith.Unimplemented let filter f m = ignore (f, m); raise Monolith.Unimplemented let filter_map f m = ignore (f, m); raise Monolith.Unimplemented let cardinal m = fold (fun _k _v sum -> sum + 1) m 0 let bindings m = fold (fun k v bindings -> (k, v) :: bindings) m [] let choose m = ignore m; raise Monolith.Unimplemented let choose_opt m = ignore m; raise Monolith.Unimplemented let find_opt k m = ignore (k, m); raise Monolith.Unimplemented let map f m = map f m let mapi f m = mapi f m monolith-20250314/demos/working/map/Candidate5.mli000066400000000000000000000017661476503452400216410ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S with type key = int monolith-20250314/demos/working/map/Main.ml000066400000000000000000000123051476503452400204020ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Declare an abstract type [map], which is implemented in two different ways by the reference implementation and by the candidate implementation. *) (* We test this map with integer keys and integer values. *) let check model = C.check model, constant "check" let map = declare_abstract_type ~check () (* -------------------------------------------------------------------------- *) (* Propose several key generators. *) (* [arbitrary_key] produces an arbitrary key within a certain interval. The interval must be reasonably small, otherwise the fuzzer wastes time trying lots of different keys. *) let arbitrary_key = Gen.lt 16 (* [extreme_key] produces the key [min_int] or [max_int]. *) let extreme_key () = if Gen.bool() then min_int else max_int (* [present_key m] produces a key that is present in the map [m]. Its implementation is not efficient, but we will likely be working with very small maps, so this should be acceptable. *) let present_key (m : R.map) () = let n = R.cardinal m in let i = Gen.int n () in let key, _value = List.nth (R.bindings m) i in key (* [key m] combines the above generators. *) let key m () = if Gen.bool() then arbitrary_key() else if Gen.bool() then extreme_key() else present_key m () (* Declare the concrete type [key]. *) let key m = int_within (key m) (* -------------------------------------------------------------------------- *) (* Declare the type [value] as an alias for [int]. *) (* We generate values within a restricted range, because we do not expect that a wide range of values is required in order to expose bugs. *) let value = lt 16 (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = map in declare "empty" spec R.empty C.empty; let spec = map ^> bool in declare "is_empty" spec R.is_empty C.is_empty; let spec = rot2 (map ^>> fun m -> key m ^> bool) in declare "mem" spec R.mem C.mem; let spec = rot3 (map ^>> fun m -> key m ^> value ^> map) in declare "add" spec R.add C.add; (* TODO update *) let spec = key R.empty ^> value ^> map in declare "singleton" spec R.singleton C.singleton; let spec = rot2 (map ^>> fun m -> key m ^> map) in declare "remove" spec R.remove C.remove; let spec = map ^> map ^> map in let k x _y = x in declare "union (fun x _y -> x)" spec (R.union k) (C.union k); (* We pass the [union] operation a non-commutative function, namely [k], so as to possibly detect a bug where [union] passes the two values in the wrong order to the user function. *) (* TODO difficulty with [compare]: the candidate implementation is free to implement an *arbitrary* total order. A reference implementation is useless here. We should observe the candidate and test whether it contradicts itself. *) (* let spec = map ^> map ^> int in declare "compare Stdlib.compare" spec (R.compare compare) (C.compare compare); *) let spec = map ^> map ^> bool in declare "equal (=)" spec (R.equal (=)) (C.equal (=)); (* TODO iter (* possible difficulty with ordering *) fold exists filter filter_map *) let spec = map ^> int in declare "cardinal" spec R.cardinal C.cardinal; (* TODO bindings *) (* again a difficulty with ordering *) (* [choose_opt] is interesting: its specification is nondeterministic. *) let spec = map ^?> option (int *** value) in declare "choose_opt" spec R.choose_opt C.choose_opt; (* [choose] is even more interesting: its specification is nondeterministic and it can raise [Not_found]. *) let spec = map ^!?> int *** value in declare "choose" spec R.choose C.choose; (* [find] can raise [Not_found], so we use the arrow combinator [^!>]. *) let spec = rot2 (map ^>> fun m -> key m ^!> value) in declare "find" spec R.find C.find; let spec = rot2 (map ^>> fun m -> key m ^> option value) in declare "find_opt" spec R.find_opt C.find_opt; (* TODO map, mapi *) () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/working/map/Main.mli000066400000000000000000000017631476503452400205610ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/working/map/Makefile000066400000000000000000000000431476503452400206200ustar00rootroot00000000000000include ../../../Makefile.monolith monolith-20250314/demos/working/map/Reference.ml000066400000000000000000000065341476503452400214230ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* We use OCaml's Map module, specialized to integer keys and integer values, as a reference implementation. *) include Map.Make(Int) (* Define the type [map]. *) type map = int t (* Some boilerplate is required in order to satisfy the signature [S]. *) let union f m1 m2 = union (fun _key v1 v2 -> Some (f v1 v2)) m1 m2 (* [choose_opt] is nondeterministic. *) open Monolith open Monolith.Print let string, (^^), utf8format = PPrint.(string, (^^), utf8format) let expected_some_result () = (* The map is nonempty, yet the candidate returned nothing. *) Invalid (fun observed -> assert_ (observed ^^ string " <> None") ^^ comment (string "The map is supposed to be nonempty.") (* If desired, we could print a list of the keys which we expect to exist in the map. *) ) let nonexistent_key k = (* The key [k] does not exist in the map. *) Invalid (fun _ -> comment (utf8format "The key %d is not supposed to exist in the map." k)) let incorrect_value k rv cv = Invalid (fun _ -> comment (utf8format "The key %d is supposed to be associated with %d, not %d." k rv cv)) let candidate_has_returned candidate m k cv = match find_opt k m with | None -> nonexistent_key k | Some rv -> if rv = cv then Valid candidate else incorrect_value k rv cv let choose_opt (m : int t) (candidate : (key * int) option) : (key * int) option diagnostic = match is_empty m, candidate with | false, None -> expected_some_result() | true, None -> Valid candidate | _, Some (k, cv) -> candidate_has_returned candidate m k cv (* [choose] is nondeterministic. *) (* We could avoid code duplication simply by testing [C.choose] indirectly: wrap it so that it has the same type as [C.choose_opt], then test it exactly like [C.choose_opt]. Here, as an exercise, we give a direct reference implementation for [choose_opt]. *) let choose (m : int t) (candidate : (key * int, exn) result) : (key * int, exn) result diagnostic = match is_empty m, candidate with | false, Error Not_found -> expected_some_result() | true, Error Not_found -> Valid candidate | _, Error e -> (* The candidate has raised some exception other than [Not_found]. *) Invalid (fun _ -> comment (utf8format "Candidate has raised %s." (Printexc.to_string e))) | _, Ok (k, cv) -> candidate_has_returned candidate m k cv monolith-20250314/demos/working/map/Reference.mli000066400000000000000000000024521476503452400215670ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S with type key = int type map = int t (* [choose] and [choose_opt] are nondeterministic. *) (* They are specialized to integer keys and values because this allows us to print better diagnostic messages. *) open Monolith val choose: int t -> (int * int, exn) result nondet val choose_opt: int t -> (int * int) option nondet monolith-20250314/demos/working/map/Signature.ml000066400000000000000000000055361476503452400214670ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This is roughly a subset of OCaml's standard signature [Map.S]. *) (* The functions that have been removed (because some of our candidate implementations do not provide them) are [min_binding], [max_binding], [min_binding_opt], [max_binding_opt], [split], [partition], [merge], [for_all], [find_first], [find_first_opt], [find_last], [find_last_opt], [to_seq], [to_seq_from], [add_seq], [of_seq]. *) (* The type of [union] has been changed so as to make it less general. Instead of accepting a function of type [key -> 'a -> 'a -> 'a option], it requires a function of type ['a -> 'a -> 'a]. *) (* The declaration of the type [t] has been changed from [+'a t] to ['a t], and the type of [empty] has been changed from ['a t] to [int t], in order to accommodate [BatIMap], which does not satisfy the stronger interface. *) module type S = sig type key type 'a t val empty: int t val is_empty: 'a t -> bool val mem: key -> 'a t -> bool val add: key -> 'a -> 'a t -> 'a t val update: key -> ('a option -> 'a option) -> 'a t -> 'a t val singleton: key -> 'a -> 'a t val remove: key -> 'a t -> 'a t val union: ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val exists: (key -> 'a -> bool) -> 'a t -> bool val filter: (key -> 'a -> bool) -> 'a t -> 'a t val filter_map: (key -> 'a -> 'b option) -> 'a t -> 'b t val cardinal: 'a t -> int val bindings: 'a t -> (key * 'a) list val choose: 'a t -> key * 'a val choose_opt: 'a t -> (key * 'a) option val find: key -> 'a t -> 'a val find_opt: key -> 'a t -> 'a option val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t end monolith-20250314/demos/working/map/dune000066400000000000000000000001711476503452400200400ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith containers-data ptmap batteries) ) monolith-20250314/demos/working/parray/000077500000000000000000000000001476503452400177045ustar00rootroot00000000000000monolith-20250314/demos/working/parray/Candidate.ml000066400000000000000000000054341476503452400221200ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* These are Jean-Christophe Filliâtre's persistent arrays. *) (* Persistent arrays implemented using Backer's trick. A persistent array is a usual array (node Array) or a change into another persistent array (node Diff). Invariant: any persistent array is a (possibly empty) linked list of Diff nodes ending on an Array node. As soon as we try to access a Diff, we reverse the linked list to move the Array node to the position we are accessing; this is achieved with the reroot function. *) type 'a t = 'a data ref and 'a data = | Array of 'a array | Diff of int * 'a * 'a t let make n v = ref (Array (Array.make n v)) let init n f = ref (Array (Array.init n f)) let rec rerootk t k = match !t with | Array _ -> k () | Diff (i, v, t') -> rerootk t' (fun () -> begin match !t' with | Array a as n -> let v' = a.(i) in a.(i) <- v; t := n; t' := Diff (i, v', t) | Diff _ -> assert false end; k()) let reroot t = rerootk t (fun () -> ()) let get t i = match !t with | Array a -> a.(i) | Diff _ -> reroot t; begin match !t with Array a -> a.(i) | Diff _ -> assert false end let set t i v = reroot t; match !t with | Array a as n -> let old = a.(i) in if old == v then t else begin a.(i) <- v; let res = ref n in t := Diff (i, old, res); res end | Diff _ -> assert false (* wrappers to apply an impure function from Array to a persistent array *) let impure f t = reroot t; match !t with Array a -> f a | Diff _ -> assert false let length t = impure Array.length t let to_list t = impure Array.to_list t let iter f t = impure (Array.iter f) t let iteri f t = impure (Array.iteri f) t let fold_left f acc t = impure (Array.fold_left f acc) t let fold_right f t acc = impure (fun a -> Array.fold_right f a acc) t monolith-20250314/demos/working/parray/Candidate.mli000066400000000000000000000017421476503452400222670ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S monolith-20250314/demos/working/parray/Main.ml000066400000000000000000000107101476503452400211210ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Define [element] as an alias for the concrete type [int]. Equip it with a deterministic generator of fresh elements. There is no point in letting afl-fuzz choose elements in a nondeterministic way; that would be a waste of random bits. *) let element = sequential() let index = int (* -------------------------------------------------------------------------- *) (* Declare an abstract type [array] of persistent arrays. *) let array = declare_abstract_type() (* -------------------------------------------------------------------------- *) (* Define wrappers that allow testing the higher-order functions. *) (* Because we use [constant] rather than [define], the definition of the wrapper won't be printed by Monolith as part of an error scenario. This could easily be fixed, but I don't want to make the code longer. *) (* [wrap_iter] converts [iter] into [to_list]. *) let wrap_iter iter a = let xs = ref [] in iter (fun x -> xs := x :: !xs) a; List.rev !xs let wrap_iter = map_into wrap_iter (wrap_iter, constant "wrap_iter") (* [wrap_iteri] is analogous, but produces a list of index-element pairs. *) let wrap_iteri iteri a = let ixs = ref [] in iteri (fun i x -> ixs := (i, x) :: !ixs) a; List.rev !ixs let wrap_iteri = map_into wrap_iteri (wrap_iteri, constant "wrap_iteri") (* [wrap_fold_left] converts [fold_left] into [rev . to_list]. *) let wrap_fold_left fold_left a = fold_left (fun xs x -> x :: xs) [] a let wrap_fold_left = map_into wrap_fold_left (wrap_fold_left, constant "wrap_fold_left") (* [wrap_fold_right] converts [fold_right] into [to_list]. *) let wrap_fold_right fold_right a = fold_right (fun x xs -> x :: xs) a [] let wrap_fold_right = map_into wrap_fold_right (wrap_fold_right, constant "wrap_fold_right") (* [wrap_init] specializes [init] with a function [f] that records the trace of the calls to [f]. This allows us to check the calls [f 0], [f 1], ... [f (n-1)] are performed in order and only once. *) let wrap_init init n = let is = ref [] in let f i = is := i :: !is; i in let a = init n f in List.rev !is, a let wrap_init = map_into wrap_init (wrap_init, constant "wrap_init") (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = lt 16 ^> element ^> array in declare "make" spec R.make C.make; let spec = wrap_init (lt 16 ^> list index *** array) in declare "init" spec R.init C.init; let spec = array ^> int in declare "length" spec R.length C.length; let spec = array ^>> fun a -> lt (R.length a) ^> element in declare "get" spec R.get C.get; let spec = array ^>> fun a -> lt (R.length a) ^> element ^> array in declare "set" spec R.set C.set; let spec = array ^> list element in declare "to_list" spec R.to_list C.to_list; let spec = wrap_iter (array ^> list element) in declare "iter" spec R.iter C.iter; let spec = wrap_iteri (array ^> list (index *** element)) in declare "iteri" spec R.iteri C.iteri; let spec = wrap_fold_left (array ^> list element) in declare "fold_left" spec R.fold_left C.fold_left; let spec = wrap_fold_right (array ^> list element) in declare "fold_right" spec R.fold_right C.fold_right; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/working/parray/Main.mli000066400000000000000000000017631476503452400213020ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/working/parray/Makefile000066400000000000000000000000431476503452400213410ustar00rootroot00000000000000include ../../../Makefile.monolith monolith-20250314/demos/working/parray/Reference.ml000066400000000000000000000021601476503452400221330ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of persistent arrays, based on mutable arrays. *) include Array let set a i x = let a = Array.copy a in Array.set a i x; a monolith-20250314/demos/working/parray/Reference.mli000066400000000000000000000017421476503452400223110ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S monolith-20250314/demos/working/parray/Signature.ml000066400000000000000000000026701476503452400222040ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* The signature of persistent arrays. *) module type S = sig type 'a t val make : int -> 'a -> 'a t val init : int -> (int -> 'a) -> 'a t val length : 'a t -> int val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t val to_list : 'a t -> 'a list val iter : ('a -> unit) -> 'a t -> unit val iteri : (int -> 'a -> unit) -> 'a t -> unit val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b end monolith-20250314/demos/working/parray/dune000066400000000000000000000001311476503452400205550ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/working/seq/000077500000000000000000000000001476503452400171765ustar00rootroot00000000000000monolith-20250314/demos/working/seq/Candidate.ml000066400000000000000000000017671476503452400214170ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* An unbounded queue. *) include Queue monolith-20250314/demos/working/seq/Main.ml000066400000000000000000000041341476503452400204160ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate let element = sequential() let stack = declare_abstract_type() let seq = declare_seq (lt 16) let aseq = declare_affine_seq (lt 16) let nonempty s = not (R.is_empty s) let () = (* The following operations work. *) let spec = element ^> stack ^> unit in declare "push" spec R.push C.push; let spec = nonempty % stack ^> element in declare "pop" spec R.pop C.pop; let spec = seq ^> stack in declare "of_seq" spec R.of_seq C.of_seq; let spec = aseq ^> stack in declare "of_seq" spec R.of_seq C.of_seq; (* This is another correct spec for [of_seq]: it consumes its argument only once. *) let spec = stack ^> seq in declare "to_seq" spec R.to_seq C.to_seq; let spec = stack ^> aseq in declare "to_seq" spec R.to_seq C.to_seq; (* This is another correct spec for [of_seq]: it produces a persistent sequence, which can also be regarded as an affine sequence. *) let id x = x in let spec = seq ^> seq in declare "id" spec id id; let spec = aseq ^> aseq in declare "id" spec id id; () let () = let fuel = 10 in main fuel monolith-20250314/demos/working/seq/Main.mli000066400000000000000000000017631476503452400205740ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/working/seq/Makefile000066400000000000000000000000431476503452400206330ustar00rootroot00000000000000include ../../../Makefile.monolith monolith-20250314/demos/working/seq/Reference.ml000066400000000000000000000017671476503452400214410ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* An unbounded queue. *) include Queue monolith-20250314/demos/working/seq/dune000066400000000000000000000001441476503452400200530ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith containers) ) monolith-20250314/demos/working/sparray/000077500000000000000000000000001476503452400200675ustar00rootroot00000000000000monolith-20250314/demos/working/sparray/Candidate.ml000066400000000000000000000051131476503452400222750ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* These are Conchon and Filliâtre's semi-persistent arrays (JFLA 2007). *) (* Whereas Conchon and Filliâtre introduce a data constructor [Invalid], which (if desired) might allow testing at runtime whether an array is invalid, we introduce no such data constructor. Therefore, it is impossible to determine at runtime whether an array is invalid; it is up to the user to never attempt to use an invalid array. *) type 'a t = 'a data ref and 'a data = | Array of 'a array | Diff of int * 'a * 'a t let make n v = ref (Array (Array.make n v)) let rec rerootk t k = match !t with | Array _ -> k () | Diff (i, v, t') -> rerootk t' (fun () -> begin match !t' with | Array a as n -> (* let v' = a.(i) in *) a.(i) <- v; t := n (* t' := Diff (i, v', t) *) | Diff _ -> assert false end; k() ) let reroot t = rerootk t (fun () -> ()) let get t i = match !t with | Array a -> a.(i) | Diff _ -> reroot t; begin match !t with Array a -> a.(i) | Diff _ -> assert false end let set t i v = reroot t; match !t with | Array a as n -> let old = a.(i) in if old == v then t else begin a.(i) <- v; let res = ref n in t := Diff (i, old, res); res end | Diff _ -> assert false let rec length t = match !t with | Array a -> Array.length a | Diff (_, _, t) -> length t (* wrappers to apply an impure function from Array to a persistent array *) let impure f t = reroot t; match !t with Array a -> f a | Diff _ -> assert false let to_list t = impure Array.to_list t monolith-20250314/demos/working/sparray/Candidate.mli000066400000000000000000000017421476503452400224520ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S monolith-20250314/demos/working/sparray/Main.ml000066400000000000000000000044251476503452400213120ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Define [element] as an alias for the concrete type [int]. Equip it with a deterministic generator of fresh elements. There is no point in letting afl-fuzz choose elements in a nondeterministic way; that would be a waste of random bits. *) let element = sequential() (* -------------------------------------------------------------------------- *) (* Declare an abstract type [array] of persistent arrays. *) let array = declare_abstract_type() (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = lt 16 ^> element ^> array in declare "make" spec R.make C.make; let spec = array ^> int in declare "length" spec R.length C.length; let spec = R.valid % array ^>> fun a -> lt (R.length a) ^> element in declare "get" spec R.get C.get; let spec = R.valid % array ^>> fun a -> lt (R.length a) ^> element ^> array in declare "set" spec R.set C.set; let spec = R.valid % array ^> list element in declare "to_list" spec R.to_list C.to_list; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/working/sparray/Main.mli000066400000000000000000000017631476503452400214650ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/working/sparray/Makefile000066400000000000000000000000431476503452400215240ustar00rootroot00000000000000include ../../../Makefile.monolith monolith-20250314/demos/working/sparray/Reference.ml000066400000000000000000000047171476503452400223300ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of semi-persistent arrays (spa). We store the data in a mutable array, which we do not mutate. We also maintain a shared mutable stack of the currently valid spas. *) type 'a t = { data: 'a array; stack: 'a t list ref } (* A spa is valid if it appears in the stack. *) let valid spa = List.memq spa !(spa.stack) (* To invalidate all of [spa]'s descendants, we pop elements off the stack until we find [spa] itself. *) let peek stack = match !stack with [] -> assert false | x :: _ -> x let pop stack = match !stack with [] -> assert false | _ :: xs -> stack := xs let push x stack = stack := x :: !stack; x let invalidate_descendants spa = while peek spa.stack != spa do pop spa.stack done let make n x = let data = Array.make n x and stack = ref [] in push { data; stack } stack let length spa = (* [length] does not require [spa] to be valid, and does not invalidate any spa. *) Array.length spa.data let get spa i = assert (valid spa); assert (0 <= i && i < length spa); invalidate_descendants spa; Array.get spa.data i let set spa i x = assert (valid spa); assert (0 <= i && i < length spa); invalidate_descendants spa; let data = Array.copy spa.data and stack = spa.stack in Array.set data i x; push { data; stack } stack let to_list spa = assert (valid spa); invalidate_descendants spa; Array.to_list spa.data (* Note: the [assert] instructions above are sanity checks; their presence is not required for the code to work. *) monolith-20250314/demos/working/sparray/Reference.mli000066400000000000000000000022321476503452400224670ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include Signature.S (* The reference implementation keeps track at runtime of which semi-persistent arrays are currently valid, and exposes this information to the user. *) val valid: 'a t -> bool monolith-20250314/demos/working/sparray/ReferenceAlternative.ml000066400000000000000000000054341476503452400245240ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* Time stamps. *) let next_stamp : unit -> int = let next = ref 0 in fun () -> let stamp = !next in next := stamp + 1; stamp (* A reference implementation of semi-persistent arrays (spa). We store the data in a mutable array, which we do not mutate. Every spa also stores a pointer to its parent (if it has one) and a time stamp that indicates when this spa was last accessed. *) type 'a t = { (* The data. *) data: 'a array; (* Our parent. *) parent: 'a t option; (* The time stamp of the last access to this spa. *) mutable last: int; } (* A spa is valid if its time stamp is greater than or equal to (i.e., no older than) its parent's time stamp and its parent is valid as well. *) let rec valid spa = match spa.parent with | None -> true | Some parent -> parent.last <= spa.last && valid parent (* Thus, by writing a new time stamp to [spa.last], we invalidate all of [spa]'s direct and indirect descendants. *) let invalidate_descendants spa = spa.last <- next_stamp() let make n x = let data = Array.make n x and parent = None and last = 0 in { data; parent; last } let length spa = (* [length] does not require [spa] to be valid, and does not invalidate any spa. *) Array.length spa.data let get spa i = assert (valid spa); assert (0 <= i && i < length spa); invalidate_descendants spa; Array.get spa.data i let set spa i x = assert (valid spa); assert (0 <= i && i < length spa); invalidate_descendants spa; let data = Array.copy spa.data in Array.set data i x; let parent = Some spa and last = spa.last in { data; parent; last } let to_list spa = assert (valid spa); invalidate_descendants spa; Array.to_list spa.data (* Note: the [assert] instructions above are sanity checks; their presence is not required for the code to work. *) monolith-20250314/demos/working/sparray/Signature.ml000066400000000000000000000023021476503452400223570ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* The signature of persistent arrays. *) module type S = sig type 'a t val make : int -> 'a -> 'a t val length : 'a t -> int val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t val to_list : 'a t -> 'a list end monolith-20250314/demos/working/sparray/dune000066400000000000000000000001311476503452400207400ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/working/stack/000077500000000000000000000000001476503452400175135ustar00rootroot00000000000000monolith-20250314/demos/working/stack/Candidate.ml000066400000000000000000000045531476503452400217300ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A candidate implementation of a bounded stack, based on an array. *) type 'a t = { data: 'a array; mutable top: int } let create n d = let data = Array.make n d and top = 0 in { data; top } let push x stack = if stack.top = Array.length stack.data then invalid_arg "push" else begin stack.data.(stack.top) <- x; stack.top <- stack.top + 1 end exception Empty let pop stack = if stack.top = 0 then raise Empty else begin stack.top <- stack.top - 1; stack.data.(stack.top) end let check (model : 'a Reference.t) stack = (* Check that the stack seems well-formed. *) assert (0 <= stack.top); assert (stack.top <= Array.length stack.data); (* Check (partially) that the stack conforms to its model. *) assert (stack.top = Reference.length model) let is_empty stack = stack.top = 0 let is_full stack = stack.top = Array.length stack.data let length stack = stack.top let get stack i = assert (0 <= i && i < stack.top); stack.data.(stack.top - 1 - i) let iter f stack = for i = 0 to length stack - 1 do f (get stack i) done let iteri f stack = for i = 0 to length stack - 1 do f i (get stack i) done let foldr f stack accu = let s = ref accu in for i = 0 to length stack - 1 do s := f (get stack i) !s done; !s let foldl f accu stack = let s = ref accu in for i = 0 to length stack - 1 do s := f !s (get stack i) done; !s monolith-20250314/demos/working/stack/Main.ml000066400000000000000000000100311476503452400207240ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith module R = Reference module C = Candidate (* -------------------------------------------------------------------------- *) (* Define [element] as an alias for the concrete type [int]. Equip it with a deterministic generator of fresh elements. There is no point in letting afl-fuzz choose elements in a nondeterministic way; that would be a waste of random bits. *) let element = sequential() (* -------------------------------------------------------------------------- *) (* Define [length] as an alias for the concrete type [int]. Equip it with a nondeterministic generator that chooses a length comprised between 0 and some fixed maximum length. *) let maximum_length = 1024 let length = le maximum_length (* -------------------------------------------------------------------------- *) (* Define [index s] as an alias for the concrete [int], together with a generator that chooses an index comprised between 0 and the length of the stack [s]. *) let index (s : _ R.t) = lt (R.length s) (* -------------------------------------------------------------------------- *) (* Declare an abstract type [stack], which is implemented in two different ways by the reference implementation and by the candidate implementation. *) let check model = C.check model, constant "check" let stack = declare_abstract_type ~check () (* -------------------------------------------------------------------------- *) (* The following functions are used in the preconditions of some operations. They are expressed in terms of the reference implementation. *) let nonfull stack = not (R.is_full stack) (* -------------------------------------------------------------------------- *) (* Declare that the exceptions [R.Empty] and [C.Empty] are related. *) let () = override_exn_eq (fun (=) e1 e2 -> match e1, e2 with | R.Empty, C.Empty -> true | _, _ -> e1 = e2 ) (* -------------------------------------------------------------------------- *) (* Declare the operations. *) let () = let spec = length ^> element ^> stack in declare "create" spec R.create C.create; let spec = element ^> (nonfull % stack) ^> unit in declare "push" spec R.push C.push; let spec = stack ^!> element in declare "pop" spec R.pop C.pop; let spec = stack ^> bool in declare "is_empty" spec R.is_empty C.is_empty; let spec = stack ^> bool in declare "is_full" spec R.is_full C.is_full; let spec = stack ^> int in declare "length" spec R.length C.length; let spec = stack ^>> (fun s -> index s ^> element) in declare "get" spec R.get C.get; let spec = iter (stack ^> list element) in declare "iter" spec R.iter C.iter; let spec = foldr (stack ^> list element) in declare "foldr" spec R.foldr C.foldr; let spec = foldl (stack ^> list element) in declare "foldl" spec R.foldl C.foldl; let spec = iteri (stack ^> list (int *** element)) in declare "iteri" spec R.iteri C.iteri; () (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main fuel monolith-20250314/demos/working/stack/Main.mli000066400000000000000000000017631476503452400211110ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/working/stack/Makefile000066400000000000000000000000431476503452400211500ustar00rootroot00000000000000include ../../../Makefile.monolith monolith-20250314/demos/working/stack/Reference.ml000066400000000000000000000057021476503452400217470ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of a bounded stack, based on OCaml's [Stack] module. *) (* [create] records the bound [n] chosen by the client, because we need it in order to be able to test whether the stack is full. Regardless of whether this test is or is not part of the library's API, we have to implement it here, because it appears in the precondition of [push], and the reference implementation must be able to test at runtime whether a precondition holds. *) (* [push] does not check whether the stack overflows. It is the client's responsibility to not push more than [n] elements onto the stack. *) (* [pop] does not check whether the stack is empty. It is the client's responsibility to not attempt to pop an element off an empty stack. *) type 'a t = { stack: 'a Stack.t; n: int } let create n _d = { stack = Stack.create(); n } let push x s = Stack.push x s.stack exception Empty = Stack.Empty let pop s = Stack.pop s.stack let length s = Stack.length s.stack let is_empty s = Stack.is_empty s.stack let is_full s = length s = s.n (* [get i s] fetches the stack element whose index is [i]. The index 0 refers to the most-recently-pushed elements. *) let get s i = (* This is inefficient. Also, it's somewhat nonstandard for a stack to offer a [get] operation. We don't really care. This is just a demo, and I need an example of an operation that has a dependent specification. *) let rec get i xs = match i, xs() with | _, Seq.Nil -> invalid_arg "get" | 0, Seq.Cons (x, _) -> x | _, Seq.Cons (_, xs) -> get (i - 1) xs in get i (Stack.to_seq s.stack) let iter f s = Stack.iter f s.stack let iteri f s = Stack.to_seq s.stack |> Seq.iteri f (* [Stack.fold] has the type of a [fold_left] function, and we want our [foldr] function to have the type of a [fold_right] function. *) let foldr f s accu = Stack.fold (fun accu x -> f x accu) accu s.stack let foldl f accu s = Stack.fold f accu s.stack monolith-20250314/demos/working/stack/dune000066400000000000000000000001311476503452400203640ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/demos/working/stack_prologue/000077500000000000000000000000001476503452400214275ustar00rootroot00000000000000monolith-20250314/demos/working/stack_prologue/Candidate.ml000066400000000000000000000043141476503452400236370ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A candidate implementation of a bounded stack, based on an array. *) (* The bound [n] chosen by the client is a functor parameter. *) module Make (X : sig val n : int end) = struct open X type 'a t = { data: 'a array; mutable top: int } let create d = let data = Array.make n d and top = 0 in { data; top } let push x stack = (* if stack.top > 2 then invalid_arg "ah!"; *) if stack.top = Array.length stack.data then invalid_arg "push" else begin stack.data.(stack.top) <- x; stack.top <- stack.top + 1 end exception Empty let pop stack = if stack.top = 0 then raise Empty else begin stack.top <- stack.top - 1; stack.data.(stack.top) end let check (model : 'a Reference.Make(X).t) stack = (* Check that the stack seems well-formed. *) assert (0 <= stack.top); assert (stack.top <= Array.length stack.data); assert (Array.length stack.data = n); (* Check (partially) that the stack conforms to its model. *) let module R = Reference.Make(X) in assert (stack.top = R.length model) (* I am surprised that applying [Reference.Make] like this works at all... *) let is_empty stack = stack.top = 0 let is_full stack = stack.top = Array.length stack.data let length stack = stack.top end monolith-20250314/demos/working/stack_prologue/Main.ml000066400000000000000000000047601476503452400226540ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Monolith let prologue () = (* Pick a bound [n] and instantiate the functors. *) let maximum_length = 1024 in let module Settings = struct let n = Gen.le maximum_length () end in let module R = Reference.Make(Settings) in let module C = Candidate.Make(Settings) in (* Print what we have just done. *) dprintf "module Settings = struct\n"; dprintf " let n = %d\n" Settings.n; dprintf "end\n"; dprintf "open Make(Settings)\n"; (* Define the types and specifications that we need. *) let element = sequential() in let stack = let check model = C.check model, constant "check" in declare_abstract_type ~check () in let nonfull s = not (R.is_full s) in (* Declare that the exceptions [R.Empty] and [C.Empty] are related. *) override_exn_eq (fun (=) e1 e2 -> match e1, e2 with | R.Empty, C.Empty -> true | _, _ -> e1 = e2 ); (* Declare the operations. *) let spec = element ^> stack in declare "create" spec R.create C.create; let spec = element ^> (nonfull % stack) ^> unit in declare "push" spec R.push C.push; let spec = stack ^!> element in declare "pop" spec R.pop C.pop; let spec = stack ^> bool in declare "is_empty" spec R.is_empty C.is_empty; let spec = stack ^> bool in declare "is_full" spec R.is_full C.is_full; let spec = stack ^> int in declare "length" spec R.length C.length (* -------------------------------------------------------------------------- *) (* Start the engine! *) let () = let fuel = 5 in main ~prologue fuel monolith-20250314/demos/working/stack_prologue/Main.mli000066400000000000000000000017631476503452400230250ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This file intentionally empty. *) monolith-20250314/demos/working/stack_prologue/Makefile000066400000000000000000000000431476503452400230640ustar00rootroot00000000000000include ../../../Makefile.monolith monolith-20250314/demos/working/stack_prologue/Reference.ml000066400000000000000000000024121476503452400236560ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* A reference implementation of a bounded stack, based on OCaml's [Stack] module. *) (* The bound [n] chosen by the client is a functor parameter. *) module Make (X : sig val n : int end) = struct open X include Stack let create _d = Stack.create() let is_full s = Stack.length s = n end monolith-20250314/demos/working/stack_prologue/dune000066400000000000000000000001311476503452400223000ustar00rootroot00000000000000(executable (name Main) (flags (:standard -w A-4-44-70 -g)) (libraries monolith) ) monolith-20250314/dune000066400000000000000000000003401476503452400144720ustar00rootroot00000000000000;; Install Makefile.monolith. ;; We use the section [lib] because this means that `ocamlfind query monolith` ;; will return the directory where the file is installed. (install (section lib) (files Makefile.monolith) ) monolith-20250314/dune-project000066400000000000000000000011451476503452400161420ustar00rootroot00000000000000(lang dune 3.11) (name monolith) (generate_opam_files true) (package (name monolith) (authors "François Pottier " ) (maintainers "François Pottier " ) (source (uri git+https://gitlab.inria.fr/fpottier/monolith.git)) (homepage https://gitlab.inria.fr/fpottier/monolith/) (bug_reports https://gitlab.inria.fr/fpottier/monolith/issues) (synopsis "A framework for strong random testing of OCaml libraries") (license "LGPL-3.0-or-later") (depends (ocaml (>= 4.12)) (afl-persistent (>= 1.3)) (pprint (>= 20200410)) ) ) monolith-20250314/header.txt000066400000000000000000000005531476503452400156130ustar00rootroot00000000000000 Monolith François Pottier Copyright Inria. All rights reserved. This file is distributed under the terms of the GNU Lesser General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version, as described in the file LICENSE. monolith-20250314/install-afl-fuzz.sh000077500000000000000000000004131476503452400173560ustar00rootroot00000000000000#!/bin/bash set -euo pipefail IFS=$'\n\t' # A script that installs afl-fuzz. cd /tmp wget http://lcamtuf.coredump.cx/afl/releases/afl-latest.tgz tar xvfz afl-latest.tgz rm afl-latest.tgz cd afl-* make # Ignore the dependency "install: all" sudo make -o all install monolith-20250314/src/000077500000000000000000000000001476503452400144065ustar00rootroot00000000000000monolith-20250314/src/BuiltinAbstract.ml000066400000000000000000000024751476503452400200420ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Spec open Support.Fun let declare_semi_abstract_type spec = (* Declare this abstract type. *) let aspec = declare_abstract_type ~var:"abs" () in (* Declare an operation that maps this abstract type to its concrete representation. Its implementation is the identity function. *) Ops.declare "Sup.Fun.id" (aspec ^> spec) id id; (* Done. *) aspec monolith-20250314/src/BuiltinArray.ml000066400000000000000000000037271476503452400173560ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Spec (* This file offers ready-made functions that help deal with arrays. *) (* -------------------------------------------------------------------------- *) (* Naive arrays. *) (* This is the simplest way of dealing with arrays. At construction time, we always generate a fresh array; we never re-use an existing array that is at hand. At deconstruction time, the fact that an array is a mutable data structure is ignored; we eagerly convert the array to a list. By doing so, we verify that the content of the array is correct now; we do not test any property related to the identity of this array. *) let constructible_array ~length spec = map_outof Array.of_list (Array.of_list, Code.constant "Array.of_list") (list ~length spec) let deconstructible_array spec = map_into Array.to_list (Array.to_list, Code.constant "Array.to_list") (list spec) let naive_array ?length:(length=Gen.lt 16) spec = ifpol (constructible_array ~length spec) (deconstructible_array spec) monolith-20250314/src/BuiltinArrows.ml000066400000000000000000000042321476503452400175450ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Spec open BuiltinExn open Support (* -------------------------------------------------------------------------- *) (* The nondeterministic arrow combinator. *) let (^?>) domain codomain = domain ^> nondet codomain (* -------------------------------------------------------------------------- *) (* A handler that catches all exceptions, introducing a [result] constructor. *) let (^!>) domain codomain = map_into Exn.handle Exn.Handle.code (domain ^> result codomain exn) (* -------------------------------------------------------------------------- *) (* A handler that catches all exceptions, introducing a [result] constructor, and inserts a [nondet] combinator so that the candidate implementation is allowed to choose whether it wishes to raise an exception. The reference implementation gets access to the candidate's result, which has type [('c, exn) result], and is expected to return its own result at type [('r, exn) result diagnostic]. *) (* The reference implementation is not expected to raise an exception, which is why it is not wrapped with [handle]. *) let id x = x let (^!?>) domain codomain = map_into id Exn.Handle.code (domain ^> nondet (result codomain exn)) monolith-20250314/src/BuiltinBool.ml000066400000000000000000000021341476503452400171620ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Spec (* A concrete type: [bool]. *) let bool = ifpol (easily_constructible Gen.bool Print.bool) (deconstructible Print.bool) monolith-20250314/src/BuiltinExn.ml000066400000000000000000000036571476503452400170340ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Spec (* -------------------------------------------------------------------------- *) (* A concrete type: [exn]. *) (* [exn] is used in the definition of the combinator [(^!>)]. *) (* We view [exn] as a deconstructible type only, because exceptions are always a result that is observed, never an argument. *) (* We equip the type [exn] with an extensible notion of equality. Initially, it is the default equality; this implies that when the candidate and reference implementations both raise an exception, they are expected to raise exactly the same exception. The user can override this with new cases. *) let exn_eq_hook : (exn -> exn -> bool) ref = ref (=) let () = GlobalState.register_ref exn_eq_hook let override_exn_eq update = exn_eq_hook := update !exn_eq_hook let exn_eq e1 e2 = !exn_eq_hook e1 e2 let print = Print.exn let equal = exn_eq, Code.infix "=exn=" (* not a value; monomorphic *) let exn = SpecDeconstructible { equal; print } monolith-20250314/src/BuiltinInt.ml000066400000000000000000000032131476503452400170200ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Spec (* A concrete type: [int]. *) (* We do not equip the type [int] with a default generator, because that would not make much sense; we have no idea what range is relevant. Thus, [int] is deconstructible, not constructible. *) let int = deconstructible Print.int (* Equipping the type [int] with a generator. *) let int_within (generate : unit -> int) = ifpol (easily_constructible generate Print.int) (int) let semi_open_interval i j = int_within (Gen.semi_open_interval i j) let closed_interval i j = int_within (Gen.closed_interval i j) let lt j = int_within (Gen.lt j) let le j = int_within (Gen.le j) let sequential () = int_within (Gen.sequential()) monolith-20250314/src/BuiltinIteration.ml000066400000000000000000000040351476503452400202270ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Spec open Support (* This file offers ready-made functions that help deal with iteration functions. *) type ('a, 'c) iter = ('a, 'c) Iteration.iter let iter spec = map_into Iteration.elements_of_iter Iteration.ElementsOfIter.code spec type ('a, 's, 'c) foldr = ('a, 's, 'c) Iteration.foldr let foldr spec = map_into Iteration.elements_of_foldr Iteration.ElementsOfFoldr.code spec type ('a, 's, 'c) foldl = ('a, 's, 'c) Iteration.foldl let foldl spec = map_into Iteration.elements_of_foldl Iteration.ElementsOfFoldl.code spec type ('a, 'b, 'c) iteri = ('a, 'b, 'c) Iteration.iteri let iteri spec = map_into Iteration.elements_of_iteri Iteration.ElementsOfIteri.code spec type ('a, 'b, 's, 'c) foldri = ('a, 'b, 's, 'c) Iteration.foldri let foldri spec = map_into Iteration.elements_of_foldri Iteration.ElementsOfFoldri.code spec type ('a, 'b, 's, 'c) foldli = ('a, 'b, 's, 'c) Iteration.foldli let foldli spec = map_into Iteration.elements_of_foldli Iteration.ElementsOfFoldli.code spec monolith-20250314/src/BuiltinRot.ml000066400000000000000000000036661476503452400170460ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Spec open Support (* Combinators for rearranging the arguments of a function. *) (* -------------------------------------------------------------------------- *) (* [rot2] moves the second argument to the first position. *) let rot2 spec = map_into Fun.rot2 Fun.Rot2.code spec (* [flip] is an alias for [rot2]. *) let flip = rot2 (* -------------------------------------------------------------------------- *) (* [rot3] moves the third argument to the first position. *) let rot3 spec = map_into Fun.rot3 Fun.Rot3.code spec (* -------------------------------------------------------------------------- *) (* [curry] transforms a function that expects a pair into a function that expects two separate arguments. *) let curry spec = map_into Fun.curry Fun.Curry.code spec (* -------------------------------------------------------------------------- *) (* [uncurry] performs the reverse transformation. *) let uncurry spec = map_into Fun.uncurry Fun.Uncurry.code spec monolith-20250314/src/BuiltinSeq.ml000066400000000000000000000123651476503452400170260ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Spec open Support (* This file offers ready-made functions that help deal with sequences. *) (* -------------------------------------------------------------------------- *) (* Naive sequences. *) (* This is the simplest way of dealing with sequences. At deconstruction time, the fact that a sequence is a lazy data structure is ignored; we eagerly convert the sequence to a list. By doing so, we verify that the sequence works correctly when it is consumed *immediately* and *once*; we do not test what happens if the sequence is consumed *later* or *several times*. *) let naive_seq ?length:(length=Gen.lt 16) element = ifpol (* The construction side. *) begin list ~length element |> map_outof List.to_seq List.ToSeq.code end (* The deconstruction side. *) begin list element |> map_into List.of_seq List.OfSeq.code end (* -------------------------------------------------------------------------- *) (* Persistent sequences. *) (* There are two entirely separate aspects that must be dealt with: (1) constructing sequences, and (2) deconstructing sequences. *) (* On the construction side, we generate a sequence by first generating a list, then converting this list to a (persistent) sequence. *) (* On the deconstruction side, we declare the type of sequences as an abstract type, equipped with an operation, [to_option]. Nothing prevents Monolith from generating scenarios where a sequence is forced twice. This is good: we actually test that the sequences produced by the candidate implementation are persistent. *) (* The conversion to an option in [to_option] is required because Monolith does not have primitive support for deconstructing a value of type ['a Seq.node]. We could likely add such support, but why bother? *) let declare_seq ?length:(length=Gen.lt 16) element = ifpol (* The construction side. *) begin list ~length element |> map_outof List.to_seq List.ToSeq.code end (* The deconstruction side. *) begin (* Declare an abstract type [seq]. *) let seq = declare_abstract_type ~var:"seq" () in (* Declare the operation [to_option]. *) let spec = seq ^> option (element *** seq) in Ops.declare "Sup.Seq.to_option" spec Seq.to_option Seq.to_option; (* Return the spec [seq]. *) seq end (* -------------------------------------------------------------------------- *) (* Affine sequences. *) (* The general approach is the same as in the previous case. *) (* On the construction side, we first generate a list, then convert it (directly) to an affine sequence. *) (* On the deconstruction side, we again declare the type of sequences as an abstract type, equipped with an operation [to_option]. We must be careful, however, not to apply [to_option] twice to the same sequence. To achieve this, we must use an alternative reference implementation, ['a VSeq.t], where each suspension keeps track of whether it has been forced already and allows retrieving this information at runtime. Furthermore, we hide the fact that we use ['a VSeq.t] from the user. The reference implementation produces values of type ['a Seq.t]; we map them into the type ['a VSeq.t] before deconstructing them. The user does not see this at all; in particular, the operation [to_option] is printed as [Seq.to_option], as this is the candidate-side implementation. *) let declare_affine_seq ?length:(length=Gen.lt 16) element = ifpol (* The construction side. *) begin list ~length element |> map_outof Seq.list_to_affine_seq Seq.ListToAffineSeq.code (* One may argue that perhaps one could use [List.to_seq] on the reference side, as we do not really need to verify that the reference implementation consumes its argument at most once. *) end (* The deconstruction side. *) begin (* Declare the abstract type [seq]. *) let seq = declare_abstract_type ~var:"seq" () in (* Declare the operation [to_option]. *) let spec = VSeq.valid % seq ^> option (element *** seq) in Ops.declare "Sup.Seq.to_option" spec VSeq.to_option Seq.to_option; (* Construct a bridge. *) map_into VSeq.affine Fun.Id.code seq end monolith-20250314/src/BuiltinTuple.ml000066400000000000000000000026711476503452400173660ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Spec open Support (* This file offers ready-made functions that help deal with tuples. *) let constructible_triple spec1 spec2 spec3 = map_outof Tuple.unnest3 Tuple.Unnest3.code (spec1 *** (spec2 *** spec3)) let deconstructible_triple spec1 spec2 spec3 = map_into Tuple.nest3 Tuple.Nest3.code (spec1 *** (spec2 *** spec3)) let triple spec1 spec2 spec3 = ifpol (constructible_triple spec1 spec2 spec3) (deconstructible_triple spec1 spec2 spec3) monolith-20250314/src/Clock.ml000066400000000000000000000063561476503452400160050ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) type clock = { (* Our granularity. This is the number of ticks that we let go until we check what we have to do. A tick that is a multiple of [granularity] is said to be round. *) granularity: int; (* Our start time. *) start: float; (* An optional timeout. *) timeout: float option; (* The current time. *) mutable now: float; (* The number of ticks that have taken place. *) mutable ticks: int; (* The last time a user function [f] was called via [tick clock f]. *) mutable last: float; (* A circular array of the times at which the most recent round ticks took place. *) window: float array; (* An index into the circular window. *) mutable next: int; } let make ?timeout granularity = let start = Unix.gettimeofday() in let n = 10 (* window size *) in let clock = { granularity; start; now = start; ticks = 0; last = 0.; timeout; window = Array.make n start; next = 0; } in clock exception Timeout let check_timeout clock = match clock.timeout with | None -> () | Some timeout -> if clock.now -. clock.start > timeout then raise Timeout let tick_body clock f = (* A round tick. Record the current time. *) clock.now <- Unix.gettimeofday(); (* Update the window. *) clock.window.(clock.next) <- clock.now; let n = Array.length clock.window in clock.next <- (clock.next + 1) mod n; (* Check if roughly one new second has elapsed. If so, call the user function [f]. *) if clock.now > clock.last +. 1.0 then begin clock.last <- clock.now; f() end; (* Check whether the clock's time limit has been reached. *) check_timeout clock let[@inline] tick clock f = (* Count one tick. *) clock.ticks <- clock.ticks + 1; (* If [granularity] ticks have been counted, perform more expensive work. *) if clock.ticks mod clock.granularity = 0 then tick_body clock f let ticks clock = clock.ticks let elapsed_time clock = truncate (clock.now -. clock.start) let overall_ticks_per_second clock = truncate (float_of_int clock.ticks /. (clock.now -. clock.start)) let current_ticks_per_second clock = let n = Array.length clock.window in let oldest = clock.window.(clock.next) and newest = clock.now in truncate (float_of_int (clock.granularity * n) /. (newest -. oldest)) monolith-20250314/src/Clock.mli000066400000000000000000000046761476503452400161610ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (** A clock. *) type clock exception Timeout (** [make granularity] creates a clock. The parameter [granularity] indicates how many ticks must elapse before the clock's logic is executed. A higher granularity yields higher efficiency but lower precision. If the optional parameter [timeout] is expressed in seconds. If it is present, then this clock carries a time limit. Once the time limit has been reached, {!tick} raises the exception [Timeout]. *) val make: ?timeout:float -> int -> clock (** [tick clock f] records one tick. If the clock discovers that roughly one second has elapsed, then it calls the function [f]. If this clock carries a time limit, and if this time limit has been reached or exceeded, then, after performing its normal duty, [tick] raises the exception [Timeout]. *) val tick: clock -> (unit -> unit) -> unit (** [ticks clock] is the total number of ticks that have taken place, that is, the number of times [tick] has been called. *) val ticks: clock -> int (** [elapsed_time clock] is the time that has elapsed since the clock started, in seconds. *) val elapsed_time: clock -> int (** [overall_ticks_per_second clock] is the total number of ticks divided by the total time in seconds, rounded down. *) val overall_ticks_per_second: clock -> int (** [current_ticks_per_second clock] is an approximation of the current number of ticks per second, computed over a small sliding window. *) val current_ticks_per_second: clock -> int monolith-20250314/src/Code.ml000066400000000000000000000050701476503452400156140ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open PPrint (* We could represent a piece of OCaml code simply as a string. We could do slightly better by representing it as a PPrint document, so as to ensure nice line breaks and indentation if the code is long. We could do better yet by introducing some form of delay (a function or suspension), so as to ensure that the document is actually constructed in memory only if it is actually needed. Better still, as icing on the cake, we represent a piece of code as a function of a list of documents to a document. Thus, if the code represents an OCaml function, and if it appears in the context of an OCaml function application, we can give it access to its actual arguments. This allows certain low-level optimizations, e.g., using infix syntax when a binary operator is applied to two arguments. *) type appearance = document list -> document type 'a code = 'a * appearance let constant c = (* Normal application syntax. *) let print docs = Print.apply (!^ c) docs in print let document doc = (* Normal application syntax. *) let print docs = Print.apply doc docs in print let infix op = let print docs = match docs with | [ arg1; arg2 ] -> (* Infix application syntax. *) Print.raw_apply [ arg1; !^ op; arg2 ] | _ -> (* Normal application syntax. *) Print.apply (parens (!^ op)) docs in print let custom print = print let value (v, _print) = v let print (_v, print) = print let apply print = print let string c = let doc = print c [] in let b = Buffer.create 32 in PPrint.ToBuffer.compact b doc; Buffer.contents b monolith-20250314/src/Code.mli000066400000000000000000000041341476503452400157650ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open PPrint (* See Monolith.mli for documentation about the following types and values. *) type appearance val constant: string -> appearance val document: document -> appearance val infix: string -> appearance type 'a code = 'a * appearance (** [custom f] describes a term whose application to a list of actual arguments [actuals] is printed as dictated by the document [f actuals]. This allows performing certain simplifications on the fly; e.g., an identity function might decide to print the application [id e] as just [e]. Be careful, though. *) val custom: (document list -> document) -> appearance (* Accessors. *) (** [value] is the first projection. *) val value: 'a code -> 'a (** [print code actuals] constructs a document which represents an application of the value [code] to the actual arguments [actuals]. *) val print: 'a code -> document list -> document (** [apply appearance actuals] is short for [print (_, appearance) actuals]. *) val apply: appearance -> document list -> document (** [string code] is a string which represents the value [code], applied to zero arguments. *) val string: 'a code -> string monolith-20250314/src/Debug.ml000066400000000000000000000030661476503452400157730ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) module[@inline] Make (X : sig val debug : bool end) = struct let indentation = ref 0 let[@inline] section k = if X.debug then begin indentation := !indentation + 2; match k() with | y -> indentation := !indentation - 2; y | exception e -> indentation := !indentation - 2; raise e end else k() let[@inline] log format = if X.debug then begin for _ = 1 to !indentation do Printf.fprintf stderr " " done; Printf.fprintf stderr format end else Printf.ifprintf stderr format end monolith-20250314/src/DelayedOutput.ml000066400000000000000000000023551476503452400175350ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) let b = Buffer.create 1024 let () = GlobalState.register (fun () -> let snapshot = Buffer.contents b in fun () -> Buffer.clear b; Buffer.add_string b snapshot ) let[@inline] dprintf format = Printf.bprintf b format let dump dst = Buffer.add_buffer dst b monolith-20250314/src/Engine.ml000066400000000000000000001665631476503452400161660ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Printf open Misc open Error open Eq open Spec open Env open Ops type document = PPrint.document (* -------------------------------------------------------------------------- *) (* This defines a function [log] which can be used for debugging. *) include Debug.Make(struct let debug = false end) (* -------------------------------------------------------------------------- *) (* Turn on the recording of backtraces, so an uncaught exception causes a backtrace to be printed before the process is aborted. *) let () = Printexc.record_backtrace true (* -------------------------------------------------------------------------- *) (* DSL syntax. *) (* It is worth noting that we do not need an *interpreter* for this syntax; we only need a *printer*. Indeed, the engine generates a program and executes it on the fly. Since generation and execution are not separate, there is no need for communication between them. Instead, the syntax is used by the engine as a way of recording its actions. Thus, when a fault is discovered, a scenario can be printed. *) (* An argument of an operation is one of the following: *) type arg = (* A constant (of an arbitrary and unknown type). *) | ArgConstant of document (* A variable (of abstract type). *) | ArgVar of var (* A unit argument. *) | ArgUnit (* A pair of arguments. *) | ArgPair of arg * arg (* An argument of type [option]. *) | ArgOption of arg option (* An argument of type [result]. *) | ArgResult of (arg, arg) result (* An argument of type [either]. *) | ArgEither of (arg, arg) Either.t (* An argument of type [list]. *) | ArgList of arg list (* An application of a constant to an argument. *) | ArgAppConstant of document * arg (* An operation is used inside an expression. An expression is one of the following. (Note the linear structure of this type, as opposed to a tree-like structure which would be more standard.) *) type expr = (* At the heart of an expression lies an operation that we wish to use. *) | EOp of string (* An application of an expression to an argument. *) | EAppL of expr * arg (* An application of some constant to an expression. *) (* At the time of writing, this constant must originate in a use of the combinator [map_into]. *) (* This constant is represented as a function of type [document list -> document]. Thus, an application of this constant to a sufficient number of arguments can possibly be beta-reduced on the fly and printed in a simpler way. *) | EAppR of (document list -> document) * expr (* An OCaml assertion is represented as a piece of text. *) type assertion = document (* A pattern indicates what to do with the result of an operation. We construct a pattern only after the two implementations (candidate and reference) have run. We use this pattern to explain the disagreement when there is one and to deconstruct the result value when there is agreement. *) type pat = | PatWildcard (* [PatWildcard] can be used at an arbitrary type. *) | PatBind of var (* [PatBind] can be used only at an abstract base type. It indicates that a variable should be bound to this value, so that this value can be used in future instructions. *) | PatRawVar of string (* [PatRawVar] represents a temporary variable. This variable is not known to the engine: it does not appear in the environment. Temporary variables are introduced by the function [break_instruction]. *) | PatObserveAgreement (* [PatObserveAgreement] is printed like a wildcard pattern. It is used only at a concrete base type. It indicates that both sides agree on this value. *) | PatObserveDisagreement of assertion (* [PatObserveDisagreement] is used only at a concrete base type. It indicates that there is a disagreement, and carries a string representation of an OCaml instruction that explains the problem. An example is "assert (observed = 0);; (* candidate finds 1 *)". This pattern plays the double role of binding the observation variable [ovar] and of carrying this OCaml instruction, which refers to the variable [ovar]. *) | PatUnit (* [PatUnit] is used at the [unit] type. *) | PatPair of pat * pat (* [PatPair] is used at a pair type. *) | PatOption of pat option (* [PatOption is used at an option type. *) | PatResult of (pat, pat) result (* [PatResult] is used at a result type. *) | PatEither of (pat, pat) Either.t (* [PatResult] is used at type [Either.t]. *) | PatNil | PatCons of pat (* [PatNil] and [PatCons] are used at a list type. [PatCons] carries a single pattern, which matches a pair. *) | PatAppR of (document list -> document) * pat (* [PatAppR] is analogous to [EAppR]; it represents an application of a constant to a pattern. This constant is typically a function provided by the user via [map_into]. *) (* The pattern form [f pat], where [f] is a function and [pat] is a pattern, does not exist in OCaml, but exists in other languages, and has well-defined meaning: deconstructing a value [v] via the pattern [f pat] amounts to deconstructing the value [f v] via the pattern [pat]. *) (* The fact that this pattern form does not exist in OCaml poses a problem when one wishes to print this pattern. Our solution is to decompose a single binding [let pat = expr] into a sequence of such bindings, connected by temporary variables. The function [break_instruction] performs this task. *) (* An instruction takes (roughly) the following form: let pat = expr;; assert (observed = ...);; The expression [expr] is always a use of an operation [op] within a certain context (e.g., an application of this operation to a list of arguments). The line [assert (observed = ...);;] is an (optional) observation. If it is present, then [observed] is an observation variable bound by [pat], and [pat] binds no other variables. This assertion compares an observed result with an expected result. It is present only if a mismatch has been detected. *) type instruction = | I of pat * expr (* When an exception is caught and turned into a piece of data, the backtrace must be recorded now, as it could otherwise be clobbered by raising another exception. *) type frozen_exn = { e: exn; backtrace: string } let freeze e = let backtrace = Printexc.get_backtrace() in { e; backtrace } (* A [failure] records what kind of failure occurred. *) type failure = (* The reference implementation raised an exception. *) | ReferenceFailure of frozen_exn (* The candidate implementation raised an exception. *) | CandidateFailure of frozen_exn (* A wrapper inserted by [map_into] or [map_outof] raised an exception. *) | ReferenceWrapperFailure of frozen_exn | CandidateWrapperFailure of frozen_exn (* The candidate produced an incorrect observable result. *) | ObservationFailure (* A well-formedness check raised an exception. *) | CheckFailure of (* x: *) var * frozen_exn (* -------------------------------------------------------------------------- *) (* Environments. *) (* We maintain an environment that maps each variable to a value, that is, a triple of a relational specification, a reference value, and a candidate value. *) (* We maintain the invariant that every value in the environment has an abstract base type. Thus, every spec in the environment is of the form [SpecBaseAbstract _]. Indeed, a value of a concrete type is observed as soon as it is produced, and does not need to be bound to a variable. A value of a structural type (product, sum, etc.) is deconstructed as soon as it is produced. *) type env = value Env.env (* -------------------------------------------------------------------------- *) (* Exceptions. *) (** The exception [PleaseBackOff] can be raised by the reference implementation to indicate that this operation (or this particular choice of arguments for this operation) should not be exercised. The reason could be that it is not permitted, or that this has not been implemented yet. This exception causes Monolith to back off and try something else. For this reason, the reference implementation must not perform any side effect before raising this exception. *) exception PleaseBackOff (** The exception [Unimplemented] can be raised by the candidate implementation to indicate that this operation (or this particular choice of arguments for this operation) should not be exercised. This exception causes Monolith to abandon the current scenario and investigate other scenarios. *) exception Unimplemented (* -------------------------------------------------------------------------- *) (* [break_instruction i] breaks the instruction [i] down into a sequence of instructions whose patterns do not contain the constructor [PAppR]. These instructions are connected via temporary variables whose names do not matter outside of this sequence of instructions (as long as they do not hide existing names). *) let break_instruction (i : instruction) : instruction list = (* A queue of instructions, waiting to be broken down. *) let waiting = Queue.create() in (* A generator of fresh names for temporary variables. *) let c = ref 0 in let gensym () = let x = !c in c := x + 1; x in (* Breaking down a pattern removes [PatAppR] constructors and enqueues more instructions into the waiting queue. *) let rec break_pat pat = match pat with | PatWildcard | PatBind _ | PatObserveAgreement | PatObserveDisagreement _ | PatUnit | PatNil | PatOption None | PatRawVar _ -> pat | PatPair (pat1, pat2) -> PatPair (break_pat pat1, break_pat pat2) | PatOption (Some pat) -> PatOption (Some (break_pat pat)) | PatResult (Ok pat) -> PatResult (Ok (break_pat pat)) | PatResult (Error pat) -> PatResult (Error (break_pat pat)) | PatEither (Either.Left pat) -> PatEither (Either.Left (break_pat pat)) | PatEither (Either.Right pat) -> PatEither (Either.Right (break_pat pat)) | PatCons pat -> PatCons (break_pat pat) | PatAppR (constant, pat) -> (* Generate a fresh temporary variable [x], which serves to name the value that we are currently looking at. *) let x = sprintf "_t%d" (gensym()) in (* Enqueue an instruction which deconstructs the function application [constant x] using the pattern [pat]. *) (* We abuse the constructor [EOp x] to print the raw variable [x]. *) let i = I (pat, EAppR (constant, EOp x)) in Queue.add i waiting; (* Done. *) PatRawVar x in (* Begin with the instruction [i] and continue until finished. *) Queue.add i waiting; let output = ref [] in while not (Queue.is_empty waiting) do let I (pat, expr) = Queue.take waiting in output := I (break_pat pat, expr) :: !output done; List.rev !output (* -------------------------------------------------------------------------- *) (* Printing instructions. *) include struct open Print (* [print_var env x] prints the variable [x], which must be bound in [env]. *) let print_var env x = (* Use a type-specific prefix, followed with the numeric level. *) (* We do not need distinct types to be associated with distinct prefixes; the presence of the numeric level alone ensures that we produce distinct names for distinct variables. *) match Env.lookup env x with | Value (SpecBaseAbstract (_, properties), _, _) -> (* Extract the base name associated with this abstract base type. *) let base = properties.aty_var in utf8format "%s%d" base (level x) | Value _ -> assert false (* every variable has abstract type *) (* [ovar] is the name of the single observation variable that is needed when we wish to name an observed value and indicate that it does not meet our expectation. *) let ovar = utf8format "observed" (* [print_arg env a] prints the argument [a], whose free variables must be bound in [env]. The resulting string is parenthesized. *) let rec print_arg env arg = match arg with | ArgConstant constant -> constant | ArgVar x -> print_var env x | ArgUnit -> unit | ArgPair (arg1, arg2) -> OCaml.tuple [ print_arg env arg1; print_arg env arg2 ] | ArgOption oarg -> option (print_arg env) oarg | ArgResult rarg -> result (print_arg env) (print_arg env) rarg | ArgEither rarg -> either (print_arg env) (print_arg env) rarg | ArgList args -> list (print_arg env) args | ArgAppConstant (constant, arg) -> parens (apply constant [ print_arg env arg ]) (* [print_expr env expr] prints the expression [expr]. The result string is not parenthesized. *) (* [print_expr] uses an auxiliary function [print_app], which descends into the left-hand side of applications and accumulates a list of actual arguments. This allows us to print an n-ary application in one swoop, and possibly to simplify it on the fly. *) let rec print_expr env expr = print_app env expr [] and print_app env expr (actuals : document list) = match expr with | EOp op -> (* We have reached the head of this n-ary application. *) apply (!^ op) actuals | EAppL (expr, arg) -> (* Descend into the left-hand side, accumulating one more actual argument. No parentheses are needed because [print_arg] prints a parenthesized string already. *) print_app env expr (print_arg env arg :: actuals) | EAppR (constant, expr) -> (* Descend into the left-hand side and immediately remark that we have reached the head of this n-ary application. Parentheses are needed because [print_expr] does not produce a parenthesized string. *) (* Here, [constant] is a function that expects a list of documents. *) constant (parens (print_expr env expr) :: actuals) (* [print_pat env pat] prints the pattern [pat], whose variables must be bound in [env]. The resulting string is parenthesized. *) let cons = !^ " ::" ^^ break 1 let rec print_pat env pat = match pat with | PatWildcard -> underscore | PatBind x -> print_var env x | PatRawVar x -> utf8string x | PatObserveAgreement -> underscore | PatObserveDisagreement _ -> ovar | PatUnit -> unit | PatPair (pat1, pat2) -> OCaml.tuple [ print_pat env pat1; print_pat env pat2 ] | PatOption opat -> option (print_pat env) opat | PatResult rpat -> result (print_pat env) (print_pat env) rpat | PatEither rpat -> either (print_pat env) (print_pat env) rpat | PatNil | PatCons _ -> print_pat_list env [] pat | PatAppR _ -> (* Assuming that this pattern has been preprocessed using [break_pat], this case cannot arise. *) assert false and print_pat_list env accu pat = match pat with | PatCons (PatPair (pat1, pat2)) -> print_pat_list env (pat1 :: accu) pat2 | PatCons _ -> assert false | PatNil -> (* We have a closed list pattern. We can use list syntax. *) let pats = List.rev accu in list (print_pat env) pats | _ -> assert (pat = PatWildcard); (* We have an unclosed list pattern. We must use cons syntax. *) let pats = List.rev (pat :: accu) in group (lparen ^^ nest 2 ( flow_map cons (print_pat env) pats ) ^^ rparen) (* [observations pat] extracts the observations (that is, the assertions) that appear in the pattern [pat]. *) (* In principle, a pattern contains at most one subpattern of the form [PatObserveDisagreement _]. This implies that [observations pat] returns a list of length at most one. *) let rec observations pat : assertion list = match pat with | PatWildcard | PatBind _ | PatRawVar _ | PatObserveAgreement | PatUnit | PatOption None | PatNil -> [] | PatObserveDisagreement assertion -> [assertion] | PatPair (pat1, pat2) -> observations pat1 @ observations pat2 | PatOption (Some pat) | PatResult (Ok pat) | PatResult (Error pat) | PatEither (Either.Left pat) | PatEither (Either.Right pat) | PatCons pat | PatAppR (_, pat) -> observations pat let observations (i : instruction) : assertion list = let I (pat, _) = i in let os = observations pat in assert (List.length os <= 1); os (* [print_simple_instruction env i] prints the instruction [i] as a toplevel binding of the form [let pat = expr]. The pattern [pat] must not contain any [PAppR] constructor. *) let print_simple_instruction env (I (pat, expr)) = toplevel_let (print_pat env pat) (print_expr env expr) (* [print_instruction env i] prints the instruction [i]. *) let print_instruction env i = separate hardline ( (* We expect that the environment [env] has already been extended with the variables bound by the pattern [pat]. *) (* Because a pattern that contains a [PAppR] constructor cannot be printed, we break the instruction [i] into a sequence of instructions that do not use this constructor, and print this sequence. *) List.map (print_simple_instruction env) (break_instruction i) @ (* Print the observations that are implicit in the instruction [i]. *) observations i ) (* [print_instructions env pc failure is] prints the instruction sequence [is]. [pc] is the instruction counter. [failure] indicates the cause of the failure that was observed. *) let rec print_instructions env pc failure is = match is with | [] -> empty | i :: is -> (* Print the instruction counter. *) utf8format "(* @%02d *) " pc ^^ align ( (* Print the instruction [i]. *) print_instruction env i ^^ (* If this is the last instruction and if the parameter [failure] shows that a well-formedness check caused a failure, print this check. Otherwise, continue. *) match is, failure with | [], CheckFailure (x, _) -> begin match Env.lookup env x with | Value (SpecBaseAbstract (_, properties), rv, _) -> let check = properties.aty_check rv in hardline ^^ Code.print check [ print_var env x ] ^^ utf8format ";; (* this check fails! *)" | _ -> assert false (* every variable has abstract type *) end | _, _ -> empty ) ^^ hardline ^^ let pc = pc + 1 in print_instructions env pc failure is (* [failure_type failure] is a one-line summary of the failure. *) let failure_type failure = match failure with | ReferenceFailure _ -> "Failure in the reference implementation" | CandidateFailure _ -> "Failure in an instruction" | CandidateWrapperFailure _ -> sprintf "Failure in a wrapper on the candidate side" | ReferenceWrapperFailure _ -> sprintf "Failure in a wrapper on the reference side" | ObservationFailure -> "Failure in an observation: candidate and reference disagree" | CheckFailure _ -> "Failure in a well-formedness check" (* [print_failure_exception failure] returns a string that describes the exception associated with the failure, if there is one. *) let print_failure_exception pc failure : string = match failure with | ObservationFailure -> (* If the problem is an observation failure, no exception was raised. *) "" | ReferenceFailure e | CandidateFailure e | ReferenceWrapperFailure e | CandidateWrapperFailure e | CheckFailure (_, e) -> (* If an exception was raised, print a full backtrace. *) sprintf "(* @%02d: The exception %s was raised. *)\n\n%s" pc (Printexc.to_string e.e) e.backtrace (* [print_failure env past failure] returns a failure message. (This is done immediately before aborting.) [past] is the list of past instructions. [failure] is the cause of the failure. *) let print_failure env past failure : string = let b = Buffer.create 1024 in let is = List.rev past in let pc = List.length is in bprintf b "(* @%02d: %s. *)\n" pc (failure_type failure); DelayedOutput.dump b; output b (print_instructions env 1 failure is); Buffer.add_string b (print_failure_exception pc failure); Buffer.contents b (* [print_equality_assertion equal rv cv] produces an equality assertion that explains why the candidate value [cv] is incorrect. It is an equality between the variable [ovar] (which denotes a candidate value) and the reference value [rv]. A comment is also printed, in which the incorrect candidate value appears. *) let print_equality_assertion equal rv cv = assert_ (Code.print equal [ ovar; rv ]) ^^ !^ ";;" ^^ candidate_finds cv end (* -------------------------------------------------------------------------- *) (* This exception is used to abort a run. It is handled in different ways when running under AFL and when running in purely random mode. *) (* Its integer argument is the fuel that was necessary to discover a bug. *) (* Its string argument is the scenario. *) exception Abort of string * int let raise_abort env past failure = let scenario = print_failure env past failure and fuel = List.length past in raise (Abort (scenario, fuel)) (* -------------------------------------------------------------------------- *) (* Constructing an argument for an operation. *) (* The [true] precondition. *) let no_requirement _ = true (* [construct_arg env spec p] constructs an argument that has type [spec] and satisfies the precondition [p]. It returns an argument as well as the result of evaluating this argument, a pair of a reference value [rv] and a candidate value [cv]. [spec] must be constructible. *) (* [construct_arg] fails if a wrapper raises an exception: see [SpecMapOutof]. This is an abnormal situation, a fatal error, most likely a programming error in the wrapper. We deal with it by wrapping this exception in a [ConstructArg] exception. An earlier version of the code used a [result] return type, but that was too painful. *) (* [construct_arg] can also raise [Gen.Reject], causing the generator to backtrack and try some other instruction. *) exception ConstructArg of arg * failure let rec construct_arg : type r c . env -> (r, c) spec -> (r -> bool) -> arg * r * c = fun env spec p -> match spec with | SpecBaseAbstract (tag, _) -> (* Pick a variable in the environment that has the desired type and that satisfies the predicate [p]. *) Env.choose env (fun x (Value (spec', rv, cv)) -> match spec' with | SpecBaseAbstract (tag', _) -> begin match Tag.equal tag tag' with | Eq -> (* The success of the tag equality test allows the following two type casts. *) let rv : r = rv and cv : c = cv in if p rv then Some (ArgVar x, rv, cv) else None | exception Tag.RuntimeTagError -> None end | _ -> assert false (* every variable has abstract type *) ) | SpecSubset (spec, q) -> (* This argument must satisfy the precondition [q]. Compute the conjunction of our argument [p] with [q], and go down. We do not adopt the naive solution of 1- making a recursive call to construct a value, and 2- checking a posteriori that this value satisfies [q]. Indeed, in the case where there is an abstract type below, we can do better -- we can test which values in the environment satisfy [q], and select a value from them. This eliminates the risk of choosing a value that does not satisfy [q]. *) construct_arg env spec (fun v -> p v && q v) | _ -> (* In all other cases, we construct an argument and verify a posteriori that the predicate [p] is satisfied. *) let (_, rv, _) as outcome = construct_arg_no_requirement env spec in if p rv then outcome else Gen.reject() (* [construct_arg_no_requirement] specializes [construct_arg] to the case where the precondition [p] is trivial (always true). This special case is common and can be handled more efficiently. *) and construct_arg_no_requirement : type r c . env -> (r, c) spec -> arg * r * c = fun env spec -> match spec with | SpecBaseAbstract _ -> (* To avoid code duplication, jump back to [construct_arg]. *) construct_arg env spec no_requirement | SpecSubset (spec, q) -> (* Easy. *) construct_arg env spec q | SpecConstructible { generate } -> (* We have a generation function, which we can use to obtain a value [v]. Because this is a concrete type, the same value works on both sides. *) let code = generate() in let arg = ArgConstant (Code.print code []) in let v = Code.value code in arg, v, v | SpecUnit -> ArgUnit, (), () | SpecPair (spec1, spec2) -> (* Construct a value for each pair component. *) let arg1, rv1, cv1 = construct_arg_no_requirement env spec1 and arg2, rv2, cv2 = construct_arg_no_requirement env spec2 in ArgPair (arg1, arg2), (rv1, rv2), (cv1, cv2) | SpecOption spec -> (* Choose between constructing [None] and constructing [Some _]. *) if Gen.bool() then ArgOption None, None, None else let arg, rv, cv = construct_arg_no_requirement env spec in ArgOption (Some arg), Some rv, Some cv | SpecResult (spec1, spec2) -> if Gen.bool() then let arg, rv, cv = construct_arg_no_requirement env spec1 in ArgResult (Ok arg), Ok rv, Ok cv else let arg, rv, cv = construct_arg_no_requirement env spec2 in ArgResult (Error arg), Error rv, Error cv | SpecEither (spec1, spec2) -> if Gen.bool() then let arg, rv, cv = construct_arg_no_requirement env spec1 in ArgEither (Either.Left arg), Either.Left rv, Either.Left cv else let arg, rv, cv = construct_arg_no_requirement env spec2 in ArgEither (Either.Right arg), Either.Right rv, Either.Right cv | SpecList (length, spec) -> (* If we view [SpecList] as strictly synonymous with a recursive specification that involves a sum type [Nil + Cons], then we should flip a coin so as to choose between [Nil] and [Cons] and continue. But this doesn't seem very smart, as it amounts to encoding the length of the list in unary notation, and yields a small probability of generating long lists. For this reason, we prefer to use a different generation strategy, where we pick the length of the list up front in the semi-open interval [0, n). *) let n = length() in let args, rvs, cvs = construct_arg_list env spec n [] [] [] in ArgList args, rvs, cvs | SpecMapOutof (rwrap, cwrap, spec) -> begin let arg, rv, cv = construct_arg_no_requirement env spec in let arg = ArgAppConstant (Code.print cwrap [], arg) in match rwrap rv with | exception e -> raise (ConstructArg (arg, ReferenceWrapperFailure (freeze e))) | rv -> match Code.value cwrap cv with | exception e -> raise (ConstructArg (arg, CandidateWrapperFailure (freeze e))) | cv -> arg, rv, cv end (* Recursive specifications are unfolded on the fly. *) | SpecDeferred spec -> construct_arg_no_requirement env (Lazy.force spec) (* [SpecIfPol] is interpreted on the fly. Its first argument represents the construction side. *) | SpecIfPol (spec, _) -> construct_arg_no_requirement env spec (* We do not expect any of the following cases to arise. *) | SpecDeconstructible _ -> assert false | SpecTop -> assert false | SpecArrow _ -> assert false | SpecDependentArrow _ -> assert false | SpecNondet _ -> assert false | SpecMapInto _ -> assert false and construct_arg_list : type r c . env -> (r, c) spec -> int -> arg list -> r list -> c list -> arg list * r list * c list = fun env spec n args rvs cvs -> if n = 0 then args, rvs, cvs else let arg, rv, cv = construct_arg_no_requirement env spec in construct_arg_list env spec (n-1) (arg :: args) (rv :: rvs) (cv :: cvs) (* [construct_arg_no_requirement env spec] generates an argument of type [spec]. It returns a triple of a reference value, a candidate value, and an argument. *) let construct_arg_no_requirement env spec = section @@ fun () -> log "Constructing an argument.\n%!"; construct_arg_no_requirement env spec (* -------------------------------------------------------------------------- *) (* Using an operation (by placing it in a context). *) (* We do this by starting with the trivial expression [EOp op] and growing it into a larger expression. *) (* [use env spec e rv cv] uses the expression [e], whose (dual) value is [rv] / [cv], and which conforms to the specification [spec]. Based on [spec], we determine how this expression should be used, that is, in what context it should be placed: e.g., if it is a function, then it should be applied to an appropriate argument. Thus, we build a larger expression, which we evaluate, and the process continues. This process goes on as long as [spec] is a "negative" type, that is, an opaque type, typically a function type. Once a "positive" type is reached, this process stops and we move on to a different phase, where the value is deconstructed. This process can fail if either the reference implementation or the candidate implementation raises an exception. Regardless of success or failure, [use] always returns the expression that was generated. In case of success, it also returns the residual value [v'] obtained by evaluating the original value in this context. In case of failure, it returns the failure observed by evaluating the original value in this context. *) let rec use : type r c . env -> (r, c) spec -> expr -> r -> c -> expr * (value, failure) result = fun env spec expr rv cv -> match spec with | SpecArrow (spec1, spec2) -> (* Remap this on the fly to a trivial dependent arrow, so as to avoid redundancy with the next case. *) use env (SpecDependentArrow (spec1, fun _ -> spec2)) expr rv cv | SpecDependentArrow (spec1, spec2) -> log "use: dependent arrow.\n%!"; begin (* Generate an argument [arg1] of type [spec1]. *) match construct_arg_no_requirement env spec1 with | exception ConstructArg (arg1, failure) -> EAppL (expr, arg1), Error failure | arg1, rv1, cv1 -> (* Construct the application of [expr] to [arg1]. *) let expr = EAppL (expr, arg1) in (* [spec2] is a function of [rv1] to a specification. Apply it. *) let spec2 = spec2 rv1 in (* Evaluate the application [expr arg1] on each side. In the absence of failures, it would not matter in which order we evaluate them. However, if the reference implementation raises [PleaseBackOff], then we wish to back off and try another operation (within the same scenario). This is safe only if the candidate implementation has not had an opportunity to perform side effects; so the reference implementation must run first. The candidate implementation is allowed to raise [Unimplemented]; in that case, because the side effects of the reference implementation cannot be undone, we start afresh. *) match rv rv1 with | exception e -> expr, Error (ReferenceFailure (freeze e)) | rv2 -> match cv cv1 with | exception e -> expr, Error (CandidateFailure (freeze e)) | cv2 -> (* Continue. *) use env spec2 expr rv2 cv2 end | SpecMapInto (rwrap, cwrap, spec) -> log "use: transform (map_into).\n%!"; begin (* The user has provided an operation of some unknown type [foo] and wants to wrap it so that it appears to have type [spec]. The user provides a wrapper of type [foo -> spec], whose implementations on the reference side and candidate side are [rwrap] and [cwrap]. *) (* Generate the expression [freeze expr]. *) let expr = EAppR (Code.print cwrap, expr) in (* Evaluate this application on each side. *) match rwrap rv with | exception e -> expr, Error (CandidateWrapperFailure (freeze e)) | rv -> match Code.value cwrap cv with | exception e -> expr, Error (ReferenceWrapperFailure (freeze e)) | cv -> (* Continue. *) use env spec expr rv cv end (* Recursive specifications are unfolded on the fly. *) | SpecDeferred spec -> log "use: deferred spec.\n%!"; use env (Lazy.force spec) expr rv cv (* [SpecIfPol] is interpreted on the fly. Its first second represents the deconstruction side. *) | SpecIfPol (_, spec) -> log "use: ifpol.\n%!"; use env spec expr rv cv | spec -> (* Done. *) log "use: done generating a context.\n%!"; expr, Ok (Value (spec, rv, cv)) (* [generate_instruction env] generates an instruction of the form [let _ = context[op]] and evaluates its right-hand side. (The wildcard pattern on the left-hand side is intended to be later replaced with a more interesting pattern [pat].) Like [use], this operation always produces an instruction; furthermore, it produces a result which tells whether evaluation resulted in a value or in a failure. *) let generate_instruction env : instruction * (value, failure) result = log "Generating an instruction.\n%!"; section @@ fun () -> (* Pick an operation. *) let op, Value (spec, rv, cv) = pick() in log "Picked operation \"%s\".\n%!" op; (* Generate an expression that uses this operation, and evaluate this expression. *) let expr, result = use env spec (EOp op) rv cv in (* Generate an instruction. At this point, we have not yet decided how to deconstruct the result, so we temporarily use a wildcard pattern. *) I (PatWildcard, expr), result (* -------------------------------------------------------------------------- *) (* Deconstructing a result. *) (* [deconstruct env rv cv spec] simultaneously deconstructs the reference value [rv] and the candidate value [cv], whose relational type is [spec]. It returns a pair of a Boolean outcome [ok] and a pattern [pat]. In [ok] is [true], the values [rv] and [cv] agree, and the pattern [pat] matches both of them. If [ok] is [false], the values [rv] and [cv] disagree, and the pattern [pat] matches [rv] but not [cv]. In the case of a success, the environment [env] is appropriately extended. In the case of a failure, it is partially extended. That should not be a problem; if it turned out to be a problem, we could easily reset it to its initial height. *) (* [deconstruct] fails if the reference implementation of a nondeterministic operation raises an exception. This is an abnormal situation. We deal with it by wrapping this exception in a [Deconstruct] exception. We lose some information as this exception is propagated back up (we forget where we were in the tree), but it seems difficult to do better. *) exception Deconstruct of failure let rec deconstruct : type r c . env -> r -> c -> (r, c) spec -> bool * pat = fun env rv cv spec -> match spec, rv, cv with | SpecTop, _, _ -> log "deconstruct: top.\n%!"; true, PatWildcard | SpecDeconstructible { equal; print }, _, _ -> log "deconstruct: deconstructible type.\n%!"; (* [equal] is a user-defined notion of equality at this type. *) if Code.value equal rv cv then (* Agreement. *) true, PatObserveAgreement else (* Disagreement. *) let assertion = print_equality_assertion equal (print rv) (print cv) in false, PatObserveDisagreement assertion | SpecBaseAbstract _, _, _ -> log "deconstruct: abstract base type.\n%!"; let x = Env.limit env in Env.bind env (Value (spec, rv, cv)); true, PatBind x | SpecUnit, (), () -> log "deconstruct: unit type.\n%!"; true, PatUnit | SpecPair (spec1, spec2), (rv1, rv2), (cv1, cv2) -> log "deconstruct: pair type.\n%!"; section @@ fun () -> let ok1, pat1 = deconstruct env rv1 cv1 spec1 in if ok1 then let ok2, pat2 = deconstruct env rv2 cv2 spec2 in if ok2 then true, PatPair (pat1, pat2) else false, PatPair (PatWildcard, pat2) else false, PatPair (pat1, PatWildcard) | SpecOption _, None, None -> log "deconstruct: option type (None/None).\n%!"; true, PatOption None | SpecOption spec, Some rv, Some cv -> log "deconstruct: option type (Some/Some).\n%!"; let ok, pat = deconstruct env rv cv spec in ok, PatOption (Some pat) | SpecOption _, None, Some _ -> log "deconstruct: option type (None/Some).\n%!"; false, PatOption None | SpecOption _, Some _, None -> log "deconstruct: option type (Some/None).\n%!"; false, PatOption (Some PatWildcard) | SpecResult (spec, _), Ok rv, Ok cv -> log "deconstruct: result type (Ok/Ok).\n%!"; let ok, pat = deconstruct env rv cv spec in ok, PatResult (Ok pat) | SpecResult (_, spec), Error rv, Error cv -> log "deconstruct: result type (Error/Error).\n%!"; let ok, pat = deconstruct env rv cv spec in ok, PatResult (Error pat) | SpecResult _, Error _, Ok _ -> log "deconstruct: option type (Error/Ok).\n%!"; false, PatResult (Error PatWildcard) | SpecResult _, Ok _, Error _ -> log "deconstruct: option type (Ok/Error).\n%!"; false, PatResult (Ok PatWildcard) | SpecEither (spec, _), Either.Left rv, Either.Left cv -> log "deconstruct: either type (Left/Left).\n%!"; let ok, pat = deconstruct env rv cv spec in ok, PatEither (Either.Left pat) | SpecEither (_, spec), Either.Right rv, Either.Right cv -> log "deconstruct: either type (Right/Right).\n%!"; let ok, pat = deconstruct env rv cv spec in ok, PatEither (Either.Right pat) | SpecEither _, Either.Right _, Either.Left _ -> log "deconstruct: option type (Right/Left).\n%!"; false, PatEither (Either.Right PatWildcard) | SpecEither _, Either.Left _, Either.Right _ -> log "deconstruct: option type (Left/Right).\n%!"; false, PatEither (Either.Left PatWildcard) | SpecList _, [], [] -> log "deconstruct: list type (Nil/Nil).\n%!"; true, PatNil | SpecList (_, element), rv :: rvs, cv :: cvs -> log "deconstruct: list type (Cons/Cons).\n%!"; (* Unfold [SpecList] on the fly. A nonempty list is viewed as an application of a unary [Cons] data constructor to a pair of an element and a list. *) let ok, pat = deconstruct env (rv, rvs) (cv, cvs) (SpecPair (element, spec)) in ok, PatCons pat | SpecList _, [], _ :: _ -> log "deconstruct: list type (Nil/Cons).\n%!"; false, PatNil | SpecList _, _ :: _, [] -> log "deconstruct: list type (Cons/Nil).\n%!"; false, PatCons (PatPair (PatWildcard, PatWildcard)) | SpecNondet spec, _, _ -> log "deconstruct: SpecNondet.\n%!"; (* We expect the reference value [rv] to be a function, which expects the candidate value [cv] as an argument, and returns a diagnostic. *) begin match rv cv with | Valid rv -> (* The reference implementation is happy with the candidate value [cv] and produces its own value [rv]. Continue. *) deconstruct env rv cv spec | Invalid assertion -> (* The reference implementation is unhappy with [cv] and produces an assertion that explains the problem. *) false, PatObserveDisagreement (assertion ovar) | exception e -> (* The reference implementation inexplicably fails. *) raise (Deconstruct (ReferenceFailure (freeze e))) end | SpecMapInto (rwrap, cwrap, spec), _, _ -> log "deconstruct: transform (map_into).\n%!"; (* Transform the values [rv] and [cv] and continue. *) let ok, pat = deconstruct env (rwrap rv) (Code.value cwrap cv) spec in (* Generate a function application pattern. *) ok, PatAppR (Code.print cwrap, pat) (* Recursive specifications are unfolded on the fly. *) | SpecDeferred spec, _, _ -> deconstruct env rv cv (Lazy.force spec) (* [SpecIfPol] is interpreted on the fly. Its first second represents the deconstruction side. *) | SpecIfPol (_, spec), _, _ -> deconstruct env rv cv spec (* We do not expect the following cases to arise. *) | SpecConstructible _, _, _ -> assert false | SpecSubset _, _, _ -> assert false | SpecArrow _, _, _ -> assert false | SpecDependentArrow _, _, _ -> assert false | SpecMapOutof _, _, _ -> assert false (* -------------------------------------------------------------------------- *) (* Well-formedness checks. *) (* The user-provided function [check] is expected to perform some kind of internal well-formedness check. It can fail by raising an arbitrary exception [e], perhaps an [Assert_failure]. It has access to both the reference value and the candidate value, so (if desired) it can check that the candidate data structure conforms to its logical model. *) let perform_checks env past = Env.foreach env (fun x (Value (spec, rv, cv)) -> (* We have a variable [x], its relational type [spec], its value [rv] in the reference implementation, and its value [cv] in the candidate implementation. *) match spec with | SpecBaseAbstract (_, properties) -> let check = Code.value (properties.aty_check rv) in begin try check cv with e -> raise_abort env past (CheckFailure (x, (freeze e))) end | _ -> assert false (* every variable has abstract type *) ) (* -------------------------------------------------------------------------- *) (* The engine's main loop. *) (* [fuel] is the number of instructions that we are still allowed to generate. [past] is a reversed list of the instructions generated and executed so far. *) let rec test fuel past env : unit = (* If the maximum number of instructions has been reached, stop. Otherwise, generate an instruction. *) if fuel > 0 then match generate_instruction env with | exception Gen.OutOfInputData -> (* The generation of a new instruction involves making choices, thus consuming input data. This can fail if there is no more input data. In that case, the test is over. We do not abort; we terminate normally, so another test can run. *) let pc = List.length past in printf "@%02d: Input data exhausted; end of this test.\n" pc | exception Gen.Reject -> (* The generation of a new instruction involves making choices, thus consuming input data. This can fail if the input data does not suit us. In that case, try generating another instruction. *) log "Generation of an instruction failed; retrying.\n"; test fuel past env | exception IllFormedSpec (op, msg) -> (* The generation of an instruction involves a call to [normalize], which can fail if a specification is ill-formed. *) error "in the specification of operation `%s`:\n%s" op msg | exception e -> (* Another exception indicates an abnormal condition, perhaps a mistake in the generation code. It should be reported, so it can be fixed. *) printf "An exception was raised during generation!\n"; raise e | _, Error (ReferenceFailure { e = PleaseBackOff; _ }) -> (* The reference implementation does not allow the operation that was chosen, or some particular use of this operation. Abandon this attempt and try some other operation within the current scenario. The reference implementation runs first and is not allowed to perform a side effect before raising [PleaseBackOff], so this is safe. *) (* We do not decrease any parameter in the recursive call: although this could cause nontermination, I don't think it can be a problem, as afl-fuzz will abort every run at some point anyway. *) test fuel past env | _, Error (CandidateFailure { e = Unimplemented; _ }) -> (* The reference implementation does not allow the operation that was chosen, or some particular use of this operation. Abandon this attempt entirely and start a new scenario. *) () | i, Error failure -> let past = i :: past in raise_abort env past failure | I (pat, expr), Ok v -> assert (pat = PatWildcard); (* Both the reference implementation and the candidate implementation have run successfully. An instruction [i] has just been constructed and executed, and a value [v] has been obtained as a result. *) (* Out of [v], we extract a reference value [rv] and a candidate value [cv], described by [spec]. *) let Value (spec, rv, cv) = v in (* We now deconstruct these values. While doing so, we check that they are in agreement; if so, we construct a pattern and extend the environment; if not, we also construct a pattern (one that explains the disagreement) and stop. *) match deconstruct env rv cv spec with | exception Deconstruct failure -> (* We do not have an exact context, so we use a wildcard pattern. The scenario that we print will not quite explain the problem, but it cannot explain the problem anyway, as the scenario is phrased in terms of the candidate implementation, and the error here lies in the reference implementation, which has a different type and takes one more argument, as [nondet] is used. *) let pat = PatWildcard in let past = I (pat, expr) :: past in raise_abort env past failure | ok, pat -> (* Record this instruction. *) let past = I (pat, expr) :: past in if not ok then begin (* The values [rv] and [cv] disagree in a concrete way, e.g., at a concrete type, or at a sum type. The pattern [pat] exhibits the problem; it is a pattern that matches [rv] but does not match [cv]. *) (* Report the problem. *) raise_abort env past ObservationFailure end else begin (* [pat] is a pattern that matches both [rv] and [cv]. *) (* Consume one unit of fuel. *) let fuel = fuel - 1 in (* Make sure that every data structure is well-formed. *) perform_checks env past; (* Continue. *) test fuel past env end (* -------------------------------------------------------------------------- *) (* In order to save the cost of allocating a fresh (empty) environment for every run, we re-use the same environment over and over. The operation [Env.clear] is extremely cheap. *) let stored : env option ref = ref None let env fuel : env = match !stored with | None -> (* Compute a bound on the size of the environment. This should ideally be computed by multiplying [fuel] by the maximum number of variables that a single operation can bind, that is, the maximum number of results of abstract type that an operation returns. For the moment, let's estimate this maximum number to be 5. *) let bound = 5 * fuel in (* Create an empty initial environment. *) let dummy_value = Value (SpecUnit, (), ()) in let env = Env.empty bound dummy_value in (* Store it for later re-use. *) stored := Some env; (* Return it. *) env | Some env -> (* We assume that every run uses the same value of [fuel], so the existing environments have an appropriate maximum size. *) Env.clear env; env (* -------------------------------------------------------------------------- *) (* Initialization. *) let test fuel = log "Beginning one test run.\n%!"; section @@ fun () -> (* No past. *) let past = [] in (* Run. *) let env = env fuel in test fuel past env; (* Done. *) log "This test run is finished.\n%!" (* -------------------------------------------------------------------------- *) (* [run prologue fuel] performs one test run. *) (* The function [prologue] is executed after the source channel has been opened, so it is allowed to call the data generation functions in the module [Gen]. It is also allowed to call [declare], [override_exn_eq], [dprintf], etc. Thus, it can modify our global state in several ways. *) (* [prologue] is an optional argument. Its default value is [ignore], which has no effect. *) let run prologue fuel = (* Restore a correct initial state for this iteration. *) GlobalState.reset(); (* Execute [prologue()], which can declare new operations, etc. *) match prologue() with | exception Gen.OutOfInputData -> log "Prologue: input data exhausted; abandoning.\n" | exception Gen.Reject -> log "Prologue: generation failure; abandoning.\n" | exception e -> printf "Prologue: an exception was raised!\n"; raise e | _ -> (* Run the test. *) test fuel (* -------------------------------------------------------------------------- *) (* [init()] performs global initialization. *) (* It is used both in random testing mode and in AFL mode. *) let init () = (* Printing the following two lines at the beginning of every scenario allows us to use [Monolith.Support], under the name [Sup], in our scenarios. *) DelayedOutput.dprintf " #require \"monolith\";;\n"; DelayedOutput.dprintf " module Sup = Monolith.Support;;\n"; (* We are about to perform many runs, and each run begins with a call to [prologue] that can modify our global state by calling functions such as [declare], [override_exn_eq], [dprintf], etc. Therefore, we must save our global state now, just once, and reset it at the beginning of every run, before calling [prologue]. *) GlobalState.save() (* -------------------------------------------------------------------------- *) (* Settings. *) type prologue = unit -> unit type fuel = int type settings = { source : string option; (**An optional file name. If this file name is present, then the engine runs in AFL mode and this file is used as a source of random bits. If it is absent, then the engine runs in random testing mode and /dev/urandom is used as a source of random bits. *) timeout : float option; (**An optional time limit, expressed in seconds. *) max_scenarios : int; (**In random testing mode, if [max_scenarios] failure scenarios are found, then testing stops. *) show_scenario : bool; (**This Boolean flag determines whether failure scenarios should be printed to the standard output channel. *) save_scenario : bool; (**This Boolean flag determines whether failure scenarios should be saved to a file in the directory [./output/crashes]. *) prologue : prologue; (**A prologue. *) fuel : fuel; (**The desired initial amount of fuel. *) } (* -------------------------------------------------------------------------- *) (* [run_afl settings] performs many test runs in AFL mode. *) (* [settings.source] must be [Some name], where [name] is the name of the input file that AFL has created for us. *) (* We use [AflPersistent.run] to perform many test runs, say 1001. Each run must open and close the source file, as it is recreated afresh by AFL for each run. *) let run_afl settings = assert (settings.source <> None); AflPersistent.run (fun () -> Gen.with_source settings.source (fun () -> try run settings.prologue settings.fuel with Abort (scenario, _fuel) -> (* Print the scenario to [stdout]. This is necessary for the user to be able to find out what happened. *) output_string stdout scenario; flush stdout; abort() ) ); 0 (* -------------------------------------------------------------------------- *) (* [tick clock fuel] ticks the clock [clock] and, once in a while, displays an information message. *) let[@inline] tick clock settings = Clock.tick clock @@ fun () -> printf "%s tests run so far (%s/s overall, %s/s now) (fuel = %d).\n%!" (summarize (Clock.ticks clock)) (summarize (Clock.overall_ticks_per_second clock)) (summarize (Clock.current_ticks_per_second clock)) settings.fuel (* [show_and_save scenario settings] logs the failure scenario [scenario] on [stdout] and saves it in a file in the directory ./output/crashes. *) let[@inline] show_and_save scenario settings = if settings.show_scenario then begin (* Print the scenario to [stdout]. *) output_string stdout scenario; print_newline(); flush stdout end; if settings.save_scenario then begin (* Write the scenario into a file. *) let temp_dir = "./output/crashes" in mkdirp temp_dir; let prefix = sprintf "scenario.%03d." settings.fuel and suffix = "" in let _, oc = Filename.open_temp_file ~temp_dir prefix suffix in output_string oc scenario; close_out_noerr oc end (* -------------------------------------------------------------------------- *) (* [run_random_loop clock settings accu] performs an unbounded number of test runs in random mode. *) (* While the tests run, we print information roughly every second. We print how many tests have been performed so far, our overall average speed, and our current speed. *) (* If a failure is discovered, the problematic scenario is printed to [stdout] and logged to a file in the directory ./output/crashes. Then, we start over with a possibly smaller value of [settings.fuel], in the hope of discovering a shorter failure scenario. *) (* For each value of [settings.fuel], we use an explicit infinite loop to perform an unbounded number of runs. *) (* If the clock [clock] has no time limit, then [run_random_loop] never terminates. If this clock has a time limit then [run_random_loop] terminates once the time limit has been reached, and it returns the number of failure scenarios that have been discovered and logged along the way. The accumulator [accu] records the number of failure scenarios discovered so far. *) type failures = int let rec run_random_loop settings clock (accu : failures) : failures = try (* An infinite loop. *) while true do (* Perform one run. *) run settings.prologue settings.fuel; (* Tick the clock and, once in a while, display statistics. *) tick clock settings done; (* This cannot happen. *) assert false with | Abort (scenario, fuel) -> show_and_save scenario settings; (* We have been able to find a problem with a certain amount of fuel. Try again, with this amount. This restricts our search space, and (with luck) we might now be able to find an even shorter scenario. *) let settings = { settings with fuel } and accu = accu + 1 in if accu = settings.max_scenarios then accu else run_random_loop settings clock accu | Clock.Timeout -> accu (* [run_random settings] performs an unbounded number of test runs in random mode. *) (* The source of random bits, /dev/urandom, is opened just once; it would be pointless to close it and reopen it many times. *) let run_random settings : failures = assert (settings.source = None); Gen.with_source settings.source @@ fun () -> let granularity = 1000 in let timeout = settings.timeout in let clock = Clock.make ?timeout granularity in let accu = 0 in run_random_loop settings clock accu (* -------------------------------------------------------------------------- *) (* [parse prologue fuel] parses the command line and produces a settings record. The [fuel] parameter can be overridden by the [--fuel] setting that is provided on the command line. *) let parse prologue fuel : settings = let source, timeout, fuel, max_scenarios, save_scenario, show_scenario = ref None, ref None, ref fuel, ref max_int, ref true, ref true in let set_save_scenario b = save_scenario := b in let set_show_scenario b = show_scenario := b in let set_timeout t = timeout := Some (float_of_int t) in let spec = Arg.align [ "--fuel", Arg.Set_int fuel, " Set a fuel limit"; "--max-scenarios", Arg.Set_int max_scenarios, " Stop if this number of failure scenarios is reached"; "--save-scenario", Arg.Bool set_save_scenario, " Enable/disable saving scenarios on disk"; "--show-scenario", Arg.Bool set_show_scenario, " Enable/disable showing scenarios on stdout"; "--timeout", Arg.Int set_timeout, " Set a time limit (in seconds) (random testing mode only)"; ] in let usage = sprintf "Usage: %s " Sys.argv.(0) in Arg.parse spec (fun s -> source := Some s) usage; let source, timeout, fuel, max_scenarios, save_scenario, show_scenario = !source, !timeout, !fuel, !max_scenarios, !save_scenario, !show_scenario in { source; timeout; max_scenarios; save_scenario; show_scenario; prologue; fuel } (* -------------------------------------------------------------------------- *) (* [run settings] starts the engine. *) let run settings = init(); let failures = (* If a source file name was provided on the command line, enter AFL mode; otherwise, enter random testing mode. *) match settings.source with | Some _ -> run_afl settings | None -> run_random settings in exit (if failures > 0 then 1 else 0) (* -------------------------------------------------------------------------- *) (* [main ?prologue fuel] parses the command line and starts testing. *) let main ?(prologue = ignore) fuel = let settings = parse prologue fuel in run settings monolith-20250314/src/Engine.mli000066400000000000000000000043551476503452400163250ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* See Monolith.mli for documentation. *) type document = PPrint.document type prologue = unit -> unit type fuel = int type failures = int type settings = { source : string option; (**An optional file name. If this file name is present, then the engine runs in AFL mode and this file is used as a source of random bits. If it is absent, then the engine runs in random testing mode and /dev/urandom is used as a source of random bits. *) timeout : float option; (**An optional time limit, expressed in seconds. *) max_scenarios : int; (**In random testing mode, if [max_scenarios] failure scenarios are found, then testing stops. *) show_scenario : bool; (**This Boolean flag determines whether failure scenarios should be printed to the standard output channel. *) save_scenario : bool; (**This Boolean flag determines whether failure scenarios should be saved to a file in the directory [./output/crashes]. *) prologue : prologue; (**A prologue. *) fuel : fuel; (**The desired initial amount of fuel. *) } (* See Monolith.mli for documentation. *) val main : ?prologue:prologue -> fuel -> unit val run : settings -> failures (* See Monolith.mli for documentation. *) exception PleaseBackOff exception Unimplemented monolith-20250314/src/Env.ml000066400000000000000000000070071476503452400154740ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Misc (* Variables. *) type level = | Level of int [@@unboxed] (* a de Bruijn level: 0 is the most ancient variable *) type var = level let level (Level x) = x (* For efficiency, an environment is represented as an array, indexed by de Bruijn levels. Environment lookup and environment extension are both constant-time operations. The array is resized when necessary; this is expected to be infrequent. *) (* For efficiency, we also maintain an integer array whose size is the maximum size of the environment. This array is used as auxiliary storage in the implementation of the operation [var], which chooses an element of the environment that satisfies a predicate [p]. Outside of this operation, it is unused. *) type 'v env = { mutable data : 'v array; mutable n : int; mutable storage: int array; dummy : 'v; } let empty capacity dummy = assert (0 < capacity); let data = Array.make capacity dummy and n = 0 and storage = Array.make capacity 0 in { data; n; storage; dummy } let resize env = let data = env.data in let capacity = Array.length data in let capacity' = 2 * capacity in env.data <- Array.make capacity' env.dummy; Array.blit data 0 env.data 0 capacity; env.storage <- Array.make capacity' 0 let clear env = env.n <- 0 let length env = env.n let limit env = Level (length env) let lookup env (Level x) = env.data.(x) let rec bind env v = let { data; n; _ } = env in if n = Array.length data then begin resize env; assert (n < Array.length env.data); bind env v end else begin Array.set data n v; env.n <- n + 1 end let foreach env f = let data, n = env.data, env.n in assert (n <= Array.length data); for x = 0 to n - 1 do f (Level x) data.(x) done let choose env f = let data, n, storage = env.data, env.n, env.storage in (* Construct an auxiliary array of the indices of the values that satisfy [f]. This information is stored in the array [storage], so we save the cost of allocating and initializing an array. *) let k = ref 0 in for i = 0 to n - 1 do let x = Level i in match f x data.(i) with | None -> () | Some _w -> (* We cannot store [w], as we have no storage for it. *) (* We record the fact that [i] is a good index. *) storage.(postincrement k) <- i done; (* Pick an index among our [k] candidates. *) let i = storage.(Gen.int !k ()) in let x = Level i in (* Invoke [f] again so as to obtain [w]. *) match f x data.(i) with | Some w -> w | None -> assert false monolith-20250314/src/Env.mli000066400000000000000000000046671476503452400156560ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* Variables are represented as de Bruijn levels. *) type var (* [level x] is the numeric de Bruijn level of the variable [x]. This is a de Bruijn level, not a de Bruijn index: 0 is the most ancient variable. *) val level: var -> int (* An environment maps variables to values. *) type 'v env (* [empty capacity dummy] creates a fresh empty environment. [capacity] is the initial capacity of the vector that this (mutable) environment uses. [capacity] must be nonzero. [dummy] is a dummy value. *) val empty: int -> 'v -> 'v env (* [clear env] resets the environment [env] so that it is empty again. *) val clear: 'v env -> unit (* [limit env] is the next unbound variable in the environment [env]. *) val limit: 'v env -> var (* [lookup env x] looks up the value associated with [x] in the environment [env]. [x] must be bound in [env]. *) val lookup: 'v env -> var -> 'v (* [bind env v] extends the environment [env] with a binding of the variable [limit env] to the value [v]. The environment [env] is updated in place. *) val bind: 'v env -> 'v -> unit (* [foreach env f] applies the function [f] to every variable-value binding in the environment [env]. *) val foreach: 'v env -> (var -> 'v -> unit) -> unit (* [choose env f] chooses a variable [x] such that [f x (lookup env x)] is [Some w]. It relies on the function [Gen.int] to choose this variable. It returns the image [w] of this variable through [f]. *) val choose: 'v env -> (var -> 'v -> 'a option) -> 'a monolith-20250314/src/Eq.ml000066400000000000000000000021621476503452400153060ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* The equality GADT. A value of type [('a, 'b) eq] is a runtime witness of the equality of the types ['a] and ['b]. *) type ('a, 'b) eq = | Eq : ('a, 'a) eq monolith-20250314/src/Error.ml000066400000000000000000000034661476503452400160420ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Printf (* -------------------------------------------------------------------------- *) (* [abort()] aborts the process by sending a SIGABRT signal to itself. We seldom need to use it directly, as letting an uncaught exception escape has the same effect. We use it only when we wish to abort without displaying a backtrace. *) let abort () = flush stdout; flush stderr; let self = Unix.getpid() in Unix.kill self Sys.sigabrt; (* This point should be unreachable. *) assert false (* -------------------------------------------------------------------------- *) (* Misuses of the library by the user are reported as follows. *) (* We use [abort] rather than [exit], because we do not want a misuse to go unnoticed when running under AFL. *) let error format = ksprintf (fun msg -> printf "Error: %s\n%!" msg; abort() ) format monolith-20250314/src/Gen.ml000066400000000000000000000161411476503452400154540ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This module offers facilities for generating values of various types, based on data that is read from our standard input channel (which is controlled by afl-fuzz). *) open Misc open Error (* -------------------------------------------------------------------------- *) (* The exception [Reject] is raised to indicate that a wrong choice was made during data generation, so this test should be silently stopped. E.g., attempting to choose an object from an empty list raises [Reject]. *) exception Reject let reject () = raise Reject let guard b = if not b then reject() (* -------------------------------------------------------------------------- *) (* The data generation functions require a source of bits, which is internally represented as an input channel. *) (* The function [with_source s f] makes the source [s] available during the execution of the function call [f()]. If [s] is [None], random data is used; if [s] is [Some filename], then input data is read from the file [filename]. In the latter case, any of the data generation functions can raise [Reject] at any time, as the input data file can be exhausted. *) (* The channel through which input bits are read. *) let source = ref stdin let set_source s = match s with | None -> source := open_in "/dev/urandom" | Some filename -> source := open_in filename let close_source () = close_in_noerr !source let with_source s f = set_source s; Fun.protect ~finally:close_source f (* -------------------------------------------------------------------------- *) (* Generators. *) type 'a gen = unit -> 'a exception OutOfInputData (* [wrap f x] invokes [f x], which is expected to read some data from the input channel, and handles the exceptions that might result. *) let wrap f x = try f x with | End_of_file -> (* The input stream has been exhausted. We remap to a different exception so as to avoid any confusion. *) raise OutOfInputData | Sys_error _ -> (* The source channel seems to have been closed. It is likely that a data generation function has been invoked outside of the data generation phase. *) error "Monolith.Gen.* cannot be used outside of Monolith.main." (* [byte()] produces an unsigned 8-bit integer. *) let byte () = wrap input_byte !source (* [short()] produces an unsigned 16-bit integer. *) let short () = byte() lsl 8 lor byte() (* [long()] produces an unsigned 32-bit integer. *) let long () = assert (Sys.word_size > 32); short() lsl 16 lor short() (* [signed_long()] produces a signed 32-bit integer. *) (* On a 32-bit machine, I expect that we get only 31 bits. *) let signed_long () = wrap input_binary_int !source (* [bits()] produces a signed integer. All values of type [int] can in principle be produced. *) let bits63 () = (signed_long() lsl 31) lor (signed_long() land (1 lsl 32 - 1)) let bits () = match Sys.word_size with | 32 -> signed_long() | 64 -> bits63() | _ -> assert false (* [bool()] produces a Boolean. *) let bool () = let b = byte() in b land 1 = 1 (* [char()] produces a character. *) let char () = let b = byte() in Char.chr b (* [log2 n] is the base two logarithm of [n]. *) let rec log2 accu n = if n = 1 then accu else log2 (accu + 1) (n lsr 1) let log2 n = assert (0 < n); log2 0 n (* [next_power_of_two n] is the smallest power of two that is strictly greater than [n]. *) let next_power_of_two n = 1 lsl (log2 n + 1) (* [mask n] is a mask (a sequence of "1" bits), and it is the smallest mask such that [n land (mask n)] is [n]. *) let mask n = next_power_of_two n - 1 (* [truncate n i] truncates the integer [i], which may be larger than [n], so that it fits in the semi-open interval [0, n). *) (* This could be done just by computing [i mod n]. However, it is perhaps preferable to avoid depending on the most significant bits of [i]; this may help afl-fuzz detect that these bits are irrelevant. For this reason, we first perform a logical AND against [mask n]. *) let truncate n i = assert (0 < n); assert (0 <= i); (i land (mask n)) mod n let int n () = guard (0 < n); if n = 1 then (* Read 0 bits of input data. *) 0 else if n <= 1 lsl 8 then (* Read 8 bits of input data. *) byte() |> truncate n else if n <= 1 lsl 16 then (* Read 16 bits of input data. *) short() |> truncate n else if n <= 1 lsl 32 then long() |> truncate n else begin assert (Sys.word_size = 64); (bits63() land max_int) |> truncate n end let choose xs = let xs = Array.of_list xs in fun () -> let n = Array.length xs in let i = int n () in xs.(i) let lt j = int j let le j = int (j + 1) let semi_open_interval i j () = if i < j then begin assert (0 < j - i); (* protect against overflow *) i + int (j - i) () end else reject() (* We do not define [closed_interval i j] as [semi_open_interval i (j + 1)] because this definition does not work when [j] is [max_int]. *) let closed_interval i j () = if i <= j then begin assert (0 <= j - i && j - i < max_int); (* protect against overflow *) i + int (j - i + 1) () end else reject() let sequential () = (* The reference that is allocated here is a piece of state that may need to be reset at the beginning of every run, so that all runs begin with the same initial state. Thus, it must be declared. We do not know whether [GlobalState.save] has been called already, or has not been called yet. We exploit the fact that it is permitted to call [GlobalState.register] at any time. *) let r = ref 0 in GlobalState.register_ref r; fun () -> postincrement r let option element () = if bool() then None else Some (element()) let result left right () = if bool() then Ok (left()) else Error (right()) (* A simplified version of [List.init]. *) let rec init f accu k = if k = 0 then accu else init f (f() :: accu) (k - 1) let list n element () = init element [] (n()) let array n element () = Array.init (n ()) (fun _i -> element()) let string n char () = String.init (n ()) (fun _i -> char()) monolith-20250314/src/GlobalState.ml000066400000000000000000000040321476503452400171400ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* Before [save()] has been called, we maintain a list of [save] functions that have been registered with us. When [save()] is called, we apply each of them to one argument, so we obtain a list of [reset] functions, which we store. When [reset()] is called, we invoke each of these functions. *) type status = | BeforeSaving of (unit -> unit -> unit) list | AfterSaving of (unit -> unit) list let status = ref (BeforeSaving []) let register save = match !status with | BeforeSaving saves -> status := BeforeSaving (save :: saves) | AfterSaving _ -> (* [register] after [save] has no effect. *) () let call f = f() let save () = match !status with | BeforeSaving saves -> status := AfterSaving (List.map call saves) | AfterSaving _ -> assert false (* protocol violation *) let reset () = match !status with | BeforeSaving _ -> assert false (* protocol violation *) | AfterSaving resets -> List.iter call resets let register_ref r = register (fun () -> let snapshot = !r in fun () -> r := snapshot ) monolith-20250314/src/GlobalState.mli000066400000000000000000000043121476503452400173120ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* All global state must in principle be registered here, so it can be properly re-initialized at the beginning of each new run. *) (* [register save] registers a function [save] that is in charge of saving a piece of the global state. The function call [save()] must save the current state and return a function [reset] that restores this saved state. *) val register: (unit -> unit -> unit) -> unit (* [save()] executes all of the [save] functions that have been registered. *) val save: unit -> unit (* [reset()] executes all of the [reset] functions that have been obtained as a result of calling [save()]. *) val reset: unit -> unit (* The basic usage pattern is [register* ; save ; reset*]. That is, [save] must called once. [reset] can be called only after [save] has been called. [register] must be called before [save] has been called. *) (* For greater flexibility, we actually allow [register] to be called after [save] has been called. Such a call has no effect; indeed, if a piece of state has been allocated after a snapshot has been taken, this piece of state does not need to be reset. *) (* [register_ref r] registers a function that saves and restores the content of the reference [r]. *) val register_ref: 'a ref -> unit monolith-20250314/src/Makefile000066400000000000000000000000461476503452400160460ustar00rootroot00000000000000.PHONY: all all: @ dune build @check monolith-20250314/src/Misc.ml000066400000000000000000000027541476503452400156430ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* Postincrementation. *) let[@inline] postincrement k = let x = !k in k := x + 1; x (* Printing a number in a compact format. *) open Printf let summarize n = if n < 1000 then sprintf "%3d" n else if n < 1000000 then sprintf "%3dK" (n / 1000) else if n < 1000000000 then sprintf "%3dM" (n / 1000000) else sprintf "%3dG" (n / 1000000000) (* Creating a directory (and its parents) if they do not already exist. *) let mkdirp dirname = ignore (Sys.command (sprintf "mkdir -p \"%s\"" (String.escaped dirname))) monolith-20250314/src/Monolith.ml000066400000000000000000000025501476503452400165330ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) module Gen = Gen type 'a gen = 'a Gen.gen module Print = Print type 'a printer = 'a Print.printer module Support = Support include Code include Spec include BuiltinInt include BuiltinBool include BuiltinExn include BuiltinAbstract include BuiltinArray include BuiltinArrows include BuiltinRot include BuiltinSeq include BuiltinTuple include BuiltinIteration include Ops include DelayedOutput include Engine monolith-20250314/src/Monolith.mli000066400000000000000000001611121476503452400167040ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (**Monolith offers facilities for testing an OCaml library by comparing its implementation (known as the candidate implementation) against a reference implementation. For general information on Monolith and its workflow, please consult {{:https://gitlab.inria.fr/fpottier/monolith/-/blob/master/README.md}README.md} and the paper {{:http://cambium.inria.fr/~fpottier/publis/pottier-monolith-2021.pdf}Strong Automated Testing of OCaml Libraries}, which describes the use and the design of Monolith in somewhat greater depth than this documentation. This documentation is split up into the following parts: - Facilities for {!section:gen}. - Facilities for {!section:print}. - Combinators for constructing {!section:spec}. - Functions for setting up and starting the Monolith {!section:engine}. - Miscellaneous runtime {!section:support} functions. *) (* -------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------- *) (** {1:gen Generating Data} *) (**The submodule [Gen] offers facilities for generating values of many common types. *) module Gen : sig (**A value of type ['a gen] is a generator of values of type ['a]. A generator is a function of type [unit -> 'a]. A generator has the ability to draw random data from a source that is specified (on the command line) when the Monolith engine is started. An end user who wishes to implement generator does not have direct access to this source of random data, but can access it indirectly by calling other generators such as [bool], [byte], [bits], and so on. A generator can fail if (somehow) it detects that it has made incorrect choices and entered a dead end. It does so by invoking the functions [reject] or [guard]. This not a fatal failure. This is a silent failure that causes the engine to backtrack (to an unspecified point) and retry. Invoking a generator is permitted only while the engine is running, that is, while a call to {!main} is ongoing. *) type 'a gen = unit -> 'a (**[reject] generates nothing. It always fails. *) val reject: 'a gen (**[guard b] fails if [b] is false. *) val guard: bool -> unit (**[byte] generates a byte. A byte is viewed as an unsigned integer. It is therefore a value in the semi-open interval [\[0, 256)]. *) val byte: int gen (**[bits] generates a signed integer. *) val bits: int gen (**[bool] generates a Boolean value. *) val bool: bool gen (**[char] generates a character. *) val char: char gen (**[int n] generates an integer in the semi-open interval [\[0, n)]. If this interval is empty, the generator fails. *) val int: int -> int gen (**[semi_open_interval i j] generates an integer in the semi-open interval [\[i, j)]. If this interval is empty, the generator fails. *) val semi_open_interval: int -> int -> int gen (**[closed_interval i j] generates an integer in the closed interval [\[i, j\]]. If this interval is empty, the generator fails. *) val closed_interval: int -> int -> int gen (**[lt j] is synonymous with [int j] and with [semi_open_interval 0 j]. *) val lt: int -> int gen (**[le j] is synonymous with [closed_interval 0 j]. *) val le: int -> int gen (**[sequential()] produces a fresh stateful sequential generator of integers. This generator is deterministic. Every time this generator is invoked, it produces a new integer, counting from 0 and up. *) val sequential: unit -> int gen (**[choose xs] picks an element in the list [xs]. If this list is empty, the generator fails. *) val choose: 'a list -> 'a gen (**An option generator. *) val option: 'a gen -> 'a option gen (**A result generator. *) val result: 'a gen -> 'b gen -> ('a, 'b) result gen (**A list generator. If [n] is a length generator (where a length is a nonnegative integer) and if [element] is an element generator then [list n element] is a list generator. *) val list: int gen -> 'a gen -> 'a list gen (**An array generator. If [n] is a length generator (where a length is a nonnegative integer) and if [element] is an element generator then [array n element] is a array generator. *) val array: int gen -> 'a gen -> 'a array gen (**A string generator. If [n] is a length generator (where a length is a nonnegative integer) and if [char] is a character generator then [string n char] is a string generator. *) val string: int gen -> char gen -> string gen end (* Gen *) (**A value of type ['a gen] is a generator of values of type ['a]. *) type 'a gen = 'a Gen.gen (* -------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------- *) (**{1:print Displaying Data and Code} *) (**We use the {{:https://github.com/fpottier/pprint/}PPrint} library to pretty-print OCaml code. *) type document = PPrint.document (**The submodule [Print] offers facilities for printing OCaml values and expressions. *) module Print : sig (**A printer transforms a value to into a document. A printer is said to be safe if it produces a document that is unambiguously delimited (e.g., delimited with parentheses). It is unsafe otherwise. *) type 'a printer = 'a -> document (**[int] is an integer literal printer. It is safe. *) val int: int printer (**[bool] is a Boolean literal printer. It is safe. *) val bool: bool printer (**[char] is a character literal printer. It is safe. *) val char: char printer (**[string] is a string literal printer. It is safe. *) val string: string printer (**[option] is an option printer. It is safe. *) val option: 'a printer -> 'a option printer (**[result] is a result printer. It is safe. *) val result: 'a printer -> 'b printer -> ('a, 'b) result printer (**[pair] is a pair printer. It is safe. *) val pair: 'a printer -> 'b printer -> ('a * 'b) printer (**[list] is a list printer. It is safe. *) val list: 'a printer -> 'a list printer (**[array] is an array printer. It is safe. *) val array: 'a printer -> 'a array printer (**[parens] encloses its argument within a pair of parentheses. It is safe. If the document thus obtained does not fit a single line, then it is split over three lines and its content is indented by two spaces. *) val parens: document -> document (**[apply doc docs] constructs an OCaml application of [doc] to the list of arguments [docs]. The arguments are separated with spaces, and if the whole application does not fit on a line, then a flowing style is adopted, inserting a line break where necessary. This combinator is unsafe: the application is not parenthesized. *) val apply: document -> document list -> document (**[assert_ doc] constructs an OCaml assertion, that is, an application of the variable [assert] to the document [doc], surrounded with parentheses. This combinator is unsafe: the assertion is not parenthesized. *) val assert_: document -> document (**[comment doc] prints the document [doc] inside a comment (preceded with a breakable space). It is safe. *) val comment: document -> document (**[candidate_finds doc] prints the document [doc] inside a comment of the form [(* candidate finds _ *)]. See e.g. the demo {{:https://gitlab.inria.fr/fpottier/monolith/-/blob/master/demos/working/bag/Reference.ml}[demos/working/bag]} for an example of its use. It is safe. *) val candidate_finds: document -> document end (**A value of type ['a gen] is a printer of values of type ['a]. *) type 'a printer = 'a Print.printer (* -------------------------------------------------------------------------- *) (**A value of type [appearance] is a printable representation of an OCaml expression. One can think of the type [appearance] almost as a synonym for the type [document]. In particular, the function {!val:document} is an injection of [document] into [appearance]. The type [appearance] offers a few bells and whistles that the type [document] does not have; these include the ability to print applications in a customized manner. *) type appearance (**[constant] is an injection of [string] into [appearance]. The appearance [constant c] is printed as the string [c] (without quotes). *) val constant: string -> appearance (**[document] is an injection of [document] into [appearance]. The appearance [document doc] is printed as the document [doc]. *) val document: document -> appearance (**[infix op] is an appearance for an OCaml infix operator named [op], where [op] is the name of the operator, without parentheses. This appearance is set up so that an application of it to exactly two actual arguments is printed infix. An application of it to more or fewer than two actual arguments is printed using normal application syntax. *) val infix: string -> appearance (**A value of type ['a code] is a pair of a value of type ['a] and a printable representation of this value. Several specification combinators, including {!constructible}, {!deconstructible}, {!declare_abstract_type}, {!map_into}, and {!map_outof} expect an argument of type ['a code]. *) type 'a code = 'a * appearance (* -------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------- *) (**{1:spec Specifications} *) (**A specification is a description of an OCaml value. This value might be an argument for an operation, the result of an operation, or an operation itself. When a value is meant to be used as an argument, Monolith must be able to construct such a value. In that case, a {i constructible} specification must be given. For instance, [lt 10 *** lt 10], which means {i a pair of integers less than 10}, is a constructible specification. When a value is a result, Monolith must be able to deconstruct such a value. In that case, a {i deconstructible} specification must be given. For instance, [option (int *** int)], which means {i an optional pair of two integers}, is a deconstructible specification. When a value is an operation (a function), Monolith must be able to construct one or more arguments for this operation, to apply this operation, and to deconstruct the result. Thus, the arguments of a function type must be constructible, while its result must be deconstructible. For instance, the specification of the [pop] operation on a stack could be [nonempty % stack ^> element], which means {i [pop] expects a nonempty stack and returns an element}. Or it could be [stack ^!> element], which means {i [pop] expects a stack and either returns an element or raises an exception}. Equipping every operation with a specification is required for Monolith to know how many arguments the operation expects, what properties these arguments should satisfy, what result is produced, and what to do with this result. Some specifications are constructible, but not deconstructible. For example, the combinator {!constructible} yields specifications that are constructible, but not deconstructible. Some specifications are deconstructible, but not constructible. A typical example is {!val:int}. More generally, the combinator {!deconstructible} yields specifications that are deconstructible, but not constructible. Some specifications are both constructible and deconstructible. For example, the combinator {!ifpol} yields specifications that are both constructible and deconstructible. Some specifications are neither constructible nor deconstructible. As a typical example, the specification of an operation, built by the combinator {!(^>)}, is neither constructible nor deconstructible. This implies that Monolith has no direct support for higher-order functions. *) (**A specification of type [('r, 'c) spec] describes a value whose type on the reference side is ['r] and whose type on the candidate side is ['c]. *) type (_, _) spec (**The following combinators offer a wide variety of means of constructing specifications. *) (* -------------------------------------------------------------------------- *) (**{2:spec:data Data Types} *) (* -------------------------------------------------------------------------- *) (**{3:spec:data:basic Unit, Booleans, Top} *) (**[unit] represents the base type [unit]. This specification is constructible and deconstructible. *) val unit: (unit, unit) spec (**[bool] represents the base type [bool]. This specification is constructible and deconstructible. *) val bool: (bool, bool) spec (**[ignored] describes a result that should be ignored. This specification is deconstructible, but not constructible. *) val ignored: ('r, 'c) spec (* -------------------------------------------------------------------------- *) (**{3:spec:data:int Integers} *) (**[int] represents the basic deconstructible type [int]. This specification is deconstructible. It is {i not} constructible, because it usually does not make sense to generate an integer in the huge interval [\[min_int, max_int\]]. *) val int: (int, int) spec (**[int_within range] is the basic type [int], equipped with the generator [range]. This specification is constructible and deconstructible. *) val int_within: int gen -> (int, int) spec (**[semi_open_interval i j] is [int_within (Gen.semi_open_interval i j)]. *) val semi_open_interval: int -> int -> (int, int) spec (**[closed_interval i j] is [int_within (Gen.closed_interval i j)]. *) val closed_interval: int -> int -> (int, int) spec (**[lt j] is [int_within (Gen.lt j)]. *) val lt: int -> (int, int) spec (**[le j] is [int_within (Gen.le j)]. *) val le: int -> (int, int) spec (**[sequential()] is [int_within (Gen.sequential())]. *) val sequential: unit -> (int, int) spec (* -------------------------------------------------------------------------- *) (**{3:spec:data:exn Exceptions} *) (**[exn] represents the base type [exn]. This specification is deconstructible, but not constructible. *) val exn: (exn, exn) spec (**[override_exn_eq f] overrides the notion of equality that is associated with the type [exn]. This notion of equality is used to compare an exception raised by the reference implementation with an exception raised by the candidate implementation. By default, it is OCaml's generic equality [(=)], which means that both implementations must raise exactly the same exceptions. [override_exn_eq] allows relaxing this requirement. The function [f] receives the current notion of equality as an argument and is expected to return a new notion of equality, which is installed in place of the previous one. *) val override_exn_eq: ((exn -> exn -> bool) -> (exn -> exn -> bool)) -> unit (* -------------------------------------------------------------------------- *) (**{3:spec:data:prodsum Products and Sums} *) (**[***] is the pair type constructor. When applied to constructible specifications, it produces a constructible specification. When applied to deconstructible specifications, it produces a deconstructible specification. *) val ( *** ): ('r1, 'c1) spec -> ('r2, 'c2) spec -> ('r1 * 'r2, 'c1 * 'c2) spec (**[pair] is a synonym for [( *** )]. *) val pair: ('r1, 'c1) spec -> ('r2, 'c2) spec -> ('r1 * 'r2, 'c1 * 'c2) spec (**[triple] is the triple type constructor. (A triple is a tuple of arity 3.) When applied to constructible specifications, it produces a constructible specification. When applied to deconstructible specifications, it produces a deconstructible specification. *) val triple: ('r1, 'c1) spec -> ('r2, 'c2) spec -> ('r3, 'c3) spec -> ('r1 * 'r2 * 'r3, 'c1 * 'c2 * 'c3) spec (**[option] is the option type constructor. When applied to a constructible specification, it produces a constructible specification. When applied to a deconstructible specification, it produces a deconstructible specification. *) val option: ('r, 'c) spec -> ('r option, 'c option) spec (**[result] is the result type constructor. When applied to constructible specifications, it produces a constructible specification. When applied to deconstructible specifications, it produces a deconstructible specification. *) val result: ('r1, 'c1) spec -> ('r2, 'c2) spec -> (('r1, 'r2) result, ('c1, 'c2) result) spec (**[either] is the type constructor [Either.t]. When applied to constructible specifications, it produces a constructible specification. When applied to deconstructible specifications, it produces a deconstructible specification. *) val either: ('r1, 'c1) spec -> ('r2, 'c2) spec -> (('r1, 'r2) Either.t, ('c1, 'c2) Either.t) spec (* -------------------------------------------------------------------------- *) (**{3:spec:data:list Lists} *) (**[list ~length] is the list type constructor. When applied to a constructible specification, it produces a constructible specification. When applied to a deconstructible specification, it produces a deconstructible specification. When this specification is used in construction mode, the generator [length] controls the length of the lists that are generated. The [length] parameter is optional; if is omitted, [Gen.lt 16] is used. When this specification is used in deconstruction mode, the [length] parameter is irrelevant. *) val list: ?length: int gen -> ('r, 'c) spec -> ('r list, 'c list) spec (* -------------------------------------------------------------------------- *) (**{3:spec:data:rec Recursive Data} *) (**[fix] builds a recursive specification. *) val fix: (('r, 'c) spec -> ('r, 'c) spec) -> ('r, 'c) spec (* -------------------------------------------------------------------------- *) (**{3:spec:data:array Arrays} *) (**[naive_array ~length] is (a naive version of) the array type constructor. When applied to a constructible specification, it produces a constructible specification. When applied to a deconstructible specification, it produces a deconstructible specification. When this specification is used in construction mode, the generator [length] controls the length of the arrays that are generated. The [length] parameter is optional; if is omitted, [Gen.lt 16] is used. When this specification is used in deconstruction mode, the [length] parameter is irrelevant. This is the simplest way of dealing with arrays. At construction time, a fresh array is always generated; an existing array is never re-used. At deconstruction time, the fact that an array is a mutable data structure is ignored: the array is eagerly converted to a list. This allows testing that the current content of the array is correct. This does not allow testing any property related to the identity of this array. *) val naive_array: ?length: int gen -> ('r, 'c) spec -> ('r array, 'c array) spec (* -------------------------------------------------------------------------- *) (**{3:spec:data:seq Sequences} *) (**[naive_seq ~length] is (a naive version of) the sequence type constructor. When applied to a constructible specification, it produces a constructible specification. When applied to a deconstructible specification, it produces a deconstructible specification. When this specification is used in construction mode, the generator [length] controls the length of the sequences that are generated. The [length] parameter is optional; if is omitted, [Gen.lt 16] is used. When this specification is used in deconstruction mode, the [length] parameter is irrelevant. This is the simplest way of dealing with sequences. At construction time, it generates a persistent sequence. At deconstruction time, the fact that a sequence is a lazy data structure is ignored: the sequence is eagerly converted to a list. This allows testing that the sequence behaves in a correct way if it is consumed {i immediately} and {i once}. This does not allow testing what happens if the sequence is consumed {i later} or {i several times}. *) val naive_seq: ?length: int gen -> ('r, 'c) spec -> ('r Seq.t, 'c Seq.t) spec (**[declare_seq ~length] is a persistent sequence type constructor. When applied to a constructible specification, it produces a constructible specification. When applied to a deconstructible specification, it produces a deconstructible specification. When this specification is used in construction mode, the generator [length] controls the length of the sequences that are generated. The [length] parameter is optional; if is omitted, [Gen.lt 16] is used. When this specification is used in deconstruction mode, the [length] parameter is irrelevant. When this specification is used in deconstruction mode, it is treated as an abstract type, equipped with an operation that demands the first element of the sequence. It is possible for a sequence to be demanded several times. A sequence is not allowed to raise an exception when it is demanded: such an event is considered an error. Because [declare_seq] declares an abstract type as a side effect, it cannot be used under a dependent arrow [^>>]. It is recommended to use it at the top level only. *) val declare_seq: ?length: int gen -> ('r, 'c) spec -> ('r Seq.t, 'c Seq.t) spec (**[declare_affine_seq ~length] is an affine sequence type constructor. When applied to a constructible specification, it produces a constructible specification. When applied to a deconstructible specification, it produces a deconstructible specification. When this specification is used in construction mode, the generator [length] controls the length of the sequences that are generated. The [length] parameter is optional; if is omitted, [Gen.lt 16] is used. When this specification is used in deconstruction mode, the [length] parameter is irrelevant. When this specification is used in deconstruction mode, it is treated as an abstract type, equipped with an operation that demands the first element of the sequence. An affine sequence is demanded at most once. A sequence is not allowed to raise an exception when it is demanded: such an event is considered an error. Because [declare_affine_seq] declares an abstract type as a side effect, it cannot be used under a dependent arrow [^>>]. It is recommended to use it at the top level only. *) val declare_affine_seq: ?length: int gen -> ('r, 'c) spec -> ('r Seq.t, 'c Seq.t) spec (* -------------------------------------------------------------------------- *) (**{2:spec:fun Functions} *) (* -------------------------------------------------------------------------- *) (**{3:spec:fun:ordinary Deterministic Functions} *) (**[^>] is the ordinary arrow combinator. It describes a function of one argument. By using it several times, one can also describe curried functions of several arguments, which are common in OCaml. This combinator imposes the absence of exceptions: the reference and candidate implementations are expected to not raise any exception. In an application [domain ^> codomain], the specification [domain] must be constructible, while [codomain] must be either a function specification or deconstructible. The specification [domain ^> codomain] is neither constructible nor deconstructible. *) val (^>): ('r1, 'c1) spec -> ('r2, 'c2) spec -> ('r1 -> 'r2, 'c1 -> 'c2) spec (**[^!>] is the exceptional arrow combinator. It describes a function that may raise an exception, and it requests that this exception be caught and observed. This implies that the reference and candidate implementations are expected to raise an exception under the same circumstances, and are expected to raise comparable exceptions, according to the notion of equality that exists at type [exn]. This notion of equality can be customized by using {!override_exn_eq}. The (de)constructibility constraints are stricter than those imposed by an ordinary arrow [(^>)]. The domain must be constructible and the codomain must be deconstructible. The codomain cannot be an arrow. *) val (^!>): ('r1, 'c1) spec -> ('r2, 'c2) spec -> ('r1 -> 'r2, 'c1 -> 'c2) spec (**[^>>] is the dependent arrow constructor. It describes a function of one argument and allows naming (the reference side of) this argument, so that this argument can be referred to in the codomain. For example, the specification of a [get] function in a sequence might be [seq ^>> fun s -> lt (length s) ^> element]. The first argument, a sequence, receives the name [s]. This allows specifying that the second argument, an integer, must lie in the semi-open interval [\[0, length s)]. Here, the variable [s] denotes the data structure built by the reference implementation, so [length] must be the reference-side function that maps a sequence to its length. The (de)constructibility constraints are the same as with an ordinary arrow [(^>)]. *) val (^>>): ('r1, 'c1) spec -> ('r1 -> ('r2, 'c2) spec) -> ('r1 -> 'r2, 'c1 -> 'c2) spec (* -------------------------------------------------------------------------- *) (**{3:spec:fun:nondet Nondeterministic Functions} *) (**Using the combinator {!val:nondet} allows the reference implementation to have access to the candidate result of type ['c] produced by the candidate implementation. It must then produce a diagnostic of type ['r diagnostic]. The diagnostic [Valid r] means that the candidate result is acceptable and that the corresponding reference result is [r]. The diagnostic [Invalid cause] means that the candidate result is wrong. The function [cause] is an explanation why the candidate result is unacceptable. This function is applied to the name of a variable, such as [observed], which stands for the candidate result. It is expected to produce a piece of OCaml code that pinpoints the problem. This code could be an OCaml assertion that the observed result does not satisfy, such as [assert (observed > 0)]. It could also be just a comment, such as [(* candidate finds -2, whereas a positive number was expected *)]. Or, it could be a combination of both. The module {!module:Print} can help construct such OCaml code. *) type 'r diagnostic = | Valid of 'r | Invalid of (document -> document) (**In the common case where ['r] and ['c] are the same type, the following type abbreviation is useful. Then, using the combinator {!val:nondet} changes the type of the reference implementation from ['r] to ['r nondet]. *) type 'r nondet = 'r -> 'r diagnostic (**[nondet spec] describes the result of an operation whose specification is nondeterministic. It indicates that several results are permitted. Therefore, one cannot expect the reference implementation to produce "the" expected result. Instead, Monolith must run the candidate implementation first, and allow the reference implementation to have access to the result [c] produced by the candidate. The reference implementation is then expected to return a result of type ['r diagnostic]. If the reference implementation returns [Valid r], then the deconstruction process continues: that is, the reference result [r] and the candidate result [c] are deconstructed in the manner specified by [spec]. When ['r] and ['c] are in fact the same type, the type of [nondet] can be written under the form [('t, 't) spec -> ('t nondet, 't) spec]. [nondet] must be applied to a deconstructible specification, and produces a deconstructible specification. *) val nondet: ('r, 'c) spec -> ('c -> 'r diagnostic, 'c) spec (* One should avoid applying [nondet] to a concrete spec, as in [nondet int]. Indeed, this specification requires Monolith to compare the integer result produced by the reference implementation and the integer result produced by the candidate implementation. This is pointless, because the reference implementation has already checked that the candidate result is correct, and has (normally) returned the same result. It is recommended to use [nondet ignored] instead, so as to suppress the redundant equality check. *) (**[^?>] is the nondeterministic arrow combinator. [spec1 ^?> spec2] is a short-hand for [spec1 ^> nondet spec2]. The (de)constructibility constraints are stricter than those imposed by an ordinary arrow [(^>)]. The domain must be constructible and the codomain must be deconstructible. The codomain cannot be an arrow. *) val (^?>): ('r1, 'c1) spec -> ('r2, 'c2) spec -> ('r1 -> 'c2 -> 'r2 diagnostic, 'c1 -> 'c2) spec (**[^!?>] is an arrow combinator that combines the exception effect and the nondeterminism effect. It describes a function that may raise an exception. Furthermore, it allows nondeterminism: the candidate implementation is allowed to decide whether it wishes to return normally or to raise an exception; it is also allowed to decide what exception it wishes to raise. To deal with this flexibility, the behavior of the candidate implementation is reified as a value of type [('c2, exn) result], which the reference implementation receives as an argument. The reference implementation is then expected to either accept or reject this candidate behavior, which it does by returning a diagnostic. If it decides to accept this behavior, then it must return its own behavior as a value of type [('r2, exn) result]. The reference implementation must never raise an exception. The (de)constructibility constraints are stricter than those imposed by an ordinary arrow [(^>)]. The domain must be constructible and the codomain must be deconstructible. The codomain cannot be an arrow. *) val (^!?>): ('r1, 'c1) spec -> ('r2, 'c2) spec -> ('r1 -> ('c2, exn) result -> ('r2, exn) result diagnostic, 'c1 -> 'c2) spec (* -------------------------------------------------------------------------- *) (**{3:spec:fun:subset Function Preconditions} *) (**[%] is the subset constructor. It restricts the set of arguments that can be passed to an operation; in other words, it expresses a precondition. For example, to express the fact that the operation [pop] must be applied to a nonempty stack, one can use [nonempty % stack], where the reference-side function [nonempty] tests whether a stack is nonempty, and [stack] is the abstract type of stacks. [%] must be applied to a constructible specification, and produces a constructible specification. *) val (%): ('r -> bool) -> ('r, 'c) spec -> ('r, 'c) spec (* -------------------------------------------------------------------------- *) (**{3:spec:fun:transf Transforming Function Arguments and Results} *) (**[map_outof] specifies that a transformation must be applied to a value. The user must provide the reference side of the transformation, the candidate side of the transformation, and a specification of the input type of the transformation. It is typically used to transform an argument before passing it to an operation. [map_outof] must be applied to a constructible specification, and produces a constructible specification. *) val map_outof: ('r1 -> 'r2) -> ('c1 -> 'c2) code -> ('r1, 'c1) spec -> ('r2, 'c2) spec (**[map_into] specifies that a transformation must be applied to a value. The user must provide the reference side of the transformation, the candidate side of the transformation, and a specification of the output type of the transformation. It is typically used to transform the result of an operation, or an operation itself. [map_into] must be applied to a deconstructible specification, and produces a deconstructible specification. *) val map_into: ('r1 -> 'r2) -> ('c1 -> 'c2) code -> ('r2, 'c2) spec -> ('r1, 'c1) spec (* -------------------------------------------------------------------------- *) (**{3:spec:fun:rearranging Rearranging Function Arguments} *) (**[flip] exchanges the first two arguments of a curried function. *) val flip: ('r1 -> 'r2 -> 'r3, 'c1 -> 'c2 -> 'c3) spec -> ('r2 -> 'r1 -> 'r3, 'c2 -> 'c1 -> 'c3) spec (**[rot2] moves the second argument of a curried function to the first position. It is synonymous with [flip]. *) val rot2: ('r1 -> 'r2 -> 'r3, 'c1 -> 'c2 -> 'c3) spec -> ('r2 -> 'r1 -> 'r3, 'c2 -> 'c1 -> 'c3) spec (**[rot3] moves the third argument of a curried function to the first position. *) val rot3: ('r3 -> 'r1 -> 'r2 -> 'r4, 'c3 -> 'c1 -> 'c2 -> 'c4) spec -> ('r1 -> 'r2 -> 'r3 -> 'r4, 'c1 -> 'c2 -> 'c3 -> 'c4) spec (**[curry] transforms a function that expects a pair into a function that expects two separate arguments. *) val curry: ('r1 -> 'r2 -> 'r3, 'c1 -> 'c2 -> 'c3) spec -> ('r1 * 'r2 -> 'r3, 'c1 * 'c2 -> 'c3) spec (**[uncurry] transforms a function that expects two separate arguments into a function that expects a pair. *) val uncurry: ('r1 * 'r2 -> 'r3, 'c1 * 'c2 -> 'c3) spec -> ('r1 -> 'r2 -> 'r3, 'c1 -> 'c2 -> 'c3) spec (* -------------------------------------------------------------------------- *) (**{2:spec:iter Iteration Functions} *) (**[('a, 'c) iter] is the type of a higher-order [iter] function which produces elements of type ['a] and can be applied to a collection of type ['c]. *) type ('a, 'c) iter = ('a -> unit) -> 'c -> unit (**[iter] transforms the specification of an [elements] function, which accepts a collection and returns a list of its elements, into the specification of an [iter] function, which accepts a collection and iterates over its elements. Thus, for example, to declare an iteration function that expects a collection of type [set] and produces elements of type [elt], one would use the specification [iter (set ^> list elt)]. *) val iter: ('rc -> 'ra list, 'cc -> 'ca list) spec -> (('ra, 'rc) iter, ('ca, 'cc) iter) spec (**[('a, 's, 'c) foldr] is the type of a higher-order [foldr] function, which produces elements of type ['a], maintains a current state of type ['s], and can be applied to a collection of type ['c]. *) type ('a, 's, 'c) foldr = ('a -> 's -> 's) -> 'c -> 's -> 's (**[foldr] transforms the specification of an [elements] function, which accepts a collection and returns a list of its elements, into the specification of a [foldr] function, which accepts a collection and an initial state, iterates over the collection's elements while maintaining a current state, and returns a final state. Thus, for example, to declare an iteration function that expects a collection of type [set] and produces elements of type [elt], one would use the specification [foldr (set ^> list elt)]. *) val foldr: ('rc -> 'ra list, 'cc -> 'ca list) spec -> (('ra, 'ra list, 'rc) foldr, ('ca, 'ca list, 'cc) foldr) spec (* This combinator instantiates the [foldr] function with a state that is a list of elements. (This is visible in its type.) If the function [foldr] is polymorphic in ['s] then this is not a problem. *) (**[('a, 's, 'c) foldl] is the type of a higher-order [foldr] function, which produces elements of type ['a], maintains a current state of type ['s], and can be applied to a collection of type ['c]. In contrast with [foldr], in this variant, the state argument is passed first. *) type ('a, 's, 'c) foldl = ('s -> 'a -> 's) -> 's -> 'c -> 's (**[foldl] transforms the specification of an [elements] function, which accepts a collection and returns a list of its elements, into the specification of a [foldl] function, which accepts an initial state and a collection, iterates over the collection's elements while maintaining a current state, and returns a final state. Thus, for example, to declare an iteration function that expects a collection of type [set] and produces elements of type [elt], one would use the specification [foldl (set ^> list elt)]. [foldr] and [foldl] differ in the calling convention: in [foldr], the state is the second argument (of [foldr] itself and of the consumer function [f]), whereas in [foldl], the state is the first argument. There is no semantic difference between [foldr] and [foldl]. Neither of them dictates in what order the elements should be produced. *) val foldl: ('rc -> 'ra list, 'cc -> 'ca list) spec -> (('ra, 'ra list, 'rc) foldl, ('ca, 'ca list, 'cc) foldl) spec (**[('a, 'b, 'c) iteri] is the type of a higher-order [iter] function which produces elements of type ['a * 'b] and can be applied to a collection of type ['c]. The consumer function [f] is curried, so instead of one argument of type ['a * 'b], it expects two arguments of type ['a] and ['b]. *) type ('a, 'b, 'c) iteri = ('a -> 'b -> unit) -> 'c -> unit (**[iteri] transforms the specification of an [elements] function, which accepts a collection and returns a list of key-value pairs, into the specification of an [iteri] function, which accepts a collection and iterates over its key-value pairs. Thus, for example, to declare an iteration function that expects a collection of type [map] and produces keys of type [key] and elements of type [value], one would use the specification [iteri (map ^> list (key *** value))]. *) val iteri: ('rc -> ('ra * 'rb) list, 'cc -> ('ca * 'cb) list) spec -> (('ra, 'rb, 'rc) iteri, ('ca, 'cb, 'cc) iteri) spec (**[('a, 'b, 's, 'c) foldri] is the type of a higher-order [foldri] function, which produces elements of type ['a * 'b], maintains a current state of type ['s], and can be applied to a collection of type ['c]. The consumer function [f] is curried, so instead of one argument of type ['a * 'b], it expects two arguments of type ['a] and ['b]. *) type ('a, 'b, 's, 'c) foldri = ('a -> 'b -> 's -> 's) -> 'c -> 's -> 's (**[foldri] transforms the specification of an [elements] function, which accepts a collection and returns a list of its key-value pairs, into the specification of a [foldri] function, which accepts a collection and an initial state, iterates over the collection's elements while maintaining a current state, and returns a final state. Thus, for example, to declare an iteration function that expects a collection of type [map] and produces keys of type [key] and elements of type [value], one would use the specification [foldri (map ^> list (key *** value))]. *) val foldri: ('rc -> ('ra * 'rb) list, 'cc -> ('ca * 'cb) list) spec -> (('ra, 'rb, ('ra * 'rb) list, 'rc) foldri, ('ca, 'cb, ('ca * 'cb) list, 'cc) foldri) spec (**[('a, 'b, 's, 'c) foldri] is the type of a higher-order [foldli] function, which produces elements of type ['a * 'b], maintains a current state of type ['s], and can be applied to a collection of type ['c]. The consumer function [f] is curried, so instead of one argument of type ['a * 'b], it expects two arguments of type ['a] and ['b]. *) type ('a, 'b, 's, 'c) foldli = ('s -> 'a -> 'b -> 's) -> 's -> 'c -> 's (**[foldli] transforms the specification of an [elements] function, which accepts a collection and returns a list of its key-value pairs, into the specification of a [foldli] function, which accepts an initial state and a collection, iterates over the collection's elements while maintaining a current state, and returns a final state. Thus, for example, to declare an iteration function that expects a collection of type [map] and produces keys of type [key] and elements of type [value], one would use the specification [foldli (map ^> list (key *** value))]. *) val foldli: ('rc -> ('ra * 'rb) list, 'cc -> ('ca * 'cb) list) spec -> (('ra, 'rb, ('ra * 'rb) list, 'rc) foldli, ('ca, 'cb, ('ca * 'cb) list, 'cc) foldli) spec (* -------------------------------------------------------------------------- *) (**{2:spec:concrete Custom Concrete Types } *) (**[constructible generate] describes a basic constructible type, that is, a type ['t] that is equipped with a generator. The function [generate] must have type [unit -> 't code], which means that it must produce a pair of a value and a printable representation of this value. (See also the combinator {!easily_constructible}, which has slightly different requirements.) It is worth noting that [constructible] {i can} be used, if desired, to construct a value whose type is a function type. When a value must be constructed, the function [generate] is applied once, and the value thus obtained is used both on the reference side and on the candidate side. This explains why the return type of this combinator is [('t, 't) spec]. This specification is constructible. *) val constructible: (unit -> 't code) -> ('t, 't) spec (* -------------------------------------------------------------------------- *) (**[easily_constructible generate print] describes a basic constructible type, that is, a type ['t] that is equipped with a generator. It is a special case of {!constructible}. It is less powerful, but is easier to use. The function [generate] must have type ['t gen]. The function [print] must have type ['t printer]. These functions are combined to obtain a generator of type [unit -> 't code], which is used in a call to {!constructible}. This specification is constructible. *) val easily_constructible: 't gen -> 't printer -> ('t, 't) spec (* -------------------------------------------------------------------------- *) (**[deconstructible ~equal print] describes a basic deconstructible type, that is, a type ['t] that is equipped with an equality test and with a printer. The equality test [equal] is used to compare the values produced by the reference implementation and by the candidate implementation. (The reference value is the first argument; the candidate value is the second argument.) The argument [equal] is optional. If it is omitted, then OCaml's generic equality function [(=)] is used. Because the reference value and the candidate value are expected to have the same type, the return type of this combinator is [('t, 't) spec]. This specification is deconstructible. *) val deconstructible: ?equal:(('t -> 't -> bool) code) -> 't printer -> ('t, 't) spec (* -------------------------------------------------------------------------- *) (**{2:spec:abstract Abstract Types } *) (**[declare_abstract_type()] declares a new abstract type, whose values on the reference side have type ['r] and whose values on the candidate side have type ['c]. An abstract type is usually implemented in different ways in the reference implementation and in the candidate implementation. For instance, a sequence may be represented as a linked list in the reference implementation and as a resizeable array in the candidate implementation. The optional parameter [check] is a well-formedness check. If present, this function is applied by Monolith, after every operation, to every data structure of this abstract type that is currently at hand. This allows checking after every operation that every data structure remains well-formed. The [check] function is applied to two arguments, namely, the reference data structure of type ['r] and the candidate data structure of type ['c]. If all is well, then [check] should return [()]. If something is wrong, then [check] should raise an exception, such as [Assertion_failure _]. It is up to the user to decide how thorough (and how costly) the well-formedness check should be. Checking that the candidate data structure seems well-formed, while ignoring the reference data structure, is a possibility. Checking that the candidate data structure is well-formed and is in agreement with the reference data structure is the most comprehensive check that can be performed. The optional parameter [var] is a base name that is used for variables of this abstract type. This specification is constructible and deconstructible. Because [declare_abstract_type] declares an abstract type as a side effect, it cannot be used under a dependent arrow [^>>]. It is recommended to use it at the top level only. *) val declare_abstract_type: ?check: ('r -> ('c -> unit) code) -> ?var: string -> unit -> ('r, 'c) spec (**The function call [declare_semi_abstract_type spec] declares a new abstract type [t] and equips it with one operation, namely a one-way conversion from [t] to [spec], whose implementation is the identity function. This is typically used to disguise a function type as an abstract type. For instance, if an operation has type [a -> b -> c] and if one wishes Monolith to perform a partial application, then one should declare [b ^> c] as a semi-abstract type [t] and use the specification [a ^> t]. [declare_semi_abstract_type] must be applied to a deconstructible specification, and produces a deconstructible specification. Because [declare_semi_abstract_type] declares an abstract type as a side effect, it cannot be used under a dependent arrow [^>>]. It is recommended to use it at the top level only. *) val declare_semi_abstract_type: ('r, 'c) spec -> ('r, 'c) spec (* -------------------------------------------------------------------------- *) (**{2:spec:misc Miscellaneous} *) (**The conditional specification [ifpol neg pos] is interpreted as the specification [neg] when it is used in construction mode (that is, when it describes the input of an operation) and as the specification [pos] when it is used in deconstruction mode (that is, when it describes the output of an operation). [ifpol] is a low-level combinator that is typically used to define higher-level abstractions. In an application [ifpol neg pos], the specification [neg] must be constructible, the specification [pos] must be deconstructible, and the result is both constructible and deconstructible. *) val ifpol: ('r, 'c) spec -> ('r, 'c) spec -> ('r, 'c) spec (* -------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------- *) (**{1:engine Engine} *) (**Monolith's engine offers a very small number of operations. A typical usage scenario involves first calling {!declare} once for each operation of the library under test, then invoking either {!main} or {!run} so as to start the engine. *) (**[declare name spec reference candidate] declares the existence of an operation. Its parameters are the name of this operation, its specification, and its implementations on the reference side and on the candidate side. {!declare} can be called either before {!main} is invoked or from the function [prologue] that is passed as an argument to {!main}. It cannot be used under a dependent arrow [^>>]. *) val declare: string -> ('r, 'c) spec -> 'r -> 'c -> unit (**A [prologue] function is invoked once at the beginning of each run. It may invoke data generation functions in the module {!Gen}, declare operations using {!declare}, and produce output using {!dprintf}. Its purpose is to determine the global parameters of the run, if desired. For instance, if the library under test is a bounded stack and takes the form of a functor that expects a bound [n], then the prologue can choose a value of [n], apply the functor, and declare the operations thus obtained. The demo {{:https://gitlab.inria.fr/fpottier/monolith/-/blob/master/demos/working/stack_prologue/Main.ml}[demos/working/stack_prologue]} illustrates this. *) type prologue = unit -> unit (**The {!type:fuel} parameter determines the maximum length of a run (expressed as a number of operations). A small value, such as 5, 10, or 20, is typically used. *) type fuel = int (**The function {!run} expects a {!settings} record as a parameter. *) type settings = { source : string option; (**An optional file name. If this file name is present, then the engine runs in {i AFL mode} and this file is used as a source of random bits. If it is absent, then the engine runs in {i random testing mode} and [/dev/urandom] is used as a source of random bits. *) timeout : float option; (**An optional time limit, expressed in seconds. This time limit is relevant only in random testing mode. If a time limit is provided, then random testing stops once the limit is reached; otherwise, random testing never stops. *) max_scenarios : int; (**In random testing mode, if [max_scenarios] failure scenarios are found, then testing stops. *) show_scenario : bool; (**This Boolean flag determines whether failure scenarios should be printed to the standard output channel. *) save_scenario : bool; (**This Boolean flag determines whether failure scenarios should be saved to a file in the directory [./output/crashes]. *) prologue : prologue; (**A prologue. *) fuel : fuel; (**The desired initial amount of fuel. In random testing mode, as soon as a failure scenario is found, testing continues with a possibly reduced amount of fuel, in the hope of finding a shorter failure scenario. *) } (**The function {!run} returns the number of failure scenarios that were discovered while testing. *) type failures = int (**[run settings] sets up and runs the engine according to [settings]. In random testing mode, it returns the number of failure scenarios that were discovered while testing. In AFL mode, {!run} aborts as soon as a failure is encountered, so, if it terminates normally, then it must return 0. *) val run : settings -> failures (**[main ?prologue fuel] parses the command line to obtain a [settings] record, then runs the engine by invoking [run settings]. If [run settings] terminates then {!main} exits the process with an exit code of either 0 (which means no failure scenarios were detected) or 1 (which means that one or more failure scenarios were detected). The main (optional) command line argument is a file name, which serves as the [source] field of the [settings] record. Beyond this, the supported optional command line parameters are [--fuel ] (default: [fuel]) and [--max_scenarios ] (default: [max_int]) and [--save-scenario ] (default: [true]) and [--show-scenario ] (default: [true]) and [--timeout ] (default: no time limit). If a fuel parameter is supplied on the command line, then it overrides the value of [fuel] that is passed as an argument to {!main}. *) val main: ?prologue:prologue -> fuel -> unit (**{!dprintf} is analogous to [printf]. Its output is actually printed to the standard output channel only if a scenario that leads to a problem is discovered. In that case, it is printed at the beginning of the scenario. This can be exploited, for instance, to print a number of global settings that have been made in the prologue. {!dprintf} can be called either before {!main} is invoked or from the function [prologue] that is passed as an argument to {!main}. It cannot be used under a dependent arrow [^>>]. *) val dprintf: ('a, Buffer.t, unit) format -> 'a (**The exception [PleaseBackOff] can be raised by the reference implementation of an operation to indicate that this operation (or this particular choice of arguments for this operation) should not be exercised. The reason could be that it is not permitted, or that it has not yet been implemented. This exception causes Monolith to silently back off and try another operation. The reference implementation must not perform any side effect before raising this exception. *) exception PleaseBackOff (**The exception [Unimplemented] can be raised by the candidate implementation of an operation to indicate that this operation (or this particular choice of arguments for this operation) should not be exercised. This exception causes Monolith to silently abandon the current scenario and investigate other scenarios. *) exception Unimplemented (* -------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------- *) (**{1:support Support} *) (**The submodule [Support] offers a number of useful functions. The name of these functions can appear in an error scenario printed by Monolith. *) (* In order to find out which of these functions may be mentioned in an error scenario, grep for applications of the functions [support] and [Ops.declare]. *) module Support : sig module Tuple : sig (**[nest3] converts a triple to nested pairs. *) val nest3: 'a * 'b * 'c -> 'a * ('b * 'c) (**[unnest3] converts nested pairs to a triple. *) val unnest3: 'a * ('b * 'c) -> 'a * 'b * 'c end module Fun : sig (**The identity function. *) val id: 'a -> 'a (**Moving the second argument to the first position. *) val rot2: ('a -> 'b -> 'c) -> ('b -> 'a -> 'c) (**Moving the third argument to the first position. *) val rot3: ('a -> 'b -> 'c -> 'd) -> ('c -> 'a -> 'b -> 'd) end module Exn : sig (**Catching all exceptions. *) val handle: ('a -> 'b) -> 'a -> ('b, exn) result end module Seq : sig (**This exception is raised by [oneshot] and by several other functions that internally depend on [oneshot]. *) exception ForcedTwice (**[oneshot] transforms a function into a one-shot function. A one-shot function raises [ForcedTwice] if it is invoked twice. *) val oneshot: ('a -> 'b) -> 'a -> 'b (* currently never mentioned in an error scenario *) (**[affine] transforms a sequence into an affine sequence. An affine sequence raises [ForcedTwice] if it is forced twice. *) val affine: 'a Seq.t -> 'a Seq.t (* currently never mentioned in an error scenario *) (**[to_option] forces a sequence and converts its head to an option. *) val to_option: 'a Seq.t -> ('a * 'a Seq.t) option (**[list_to_affine_seq] transforms a list into an affine sequence. An affine sequence raises [ForcedTwice] if forced twice. *) val list_to_affine_seq: 'a list -> 'a Seq.t end module Iteration : sig (**[elements_of_iter] transforms an iteration function [iter] into an [elements] function, which returns the list of the elements of a collection. *) val elements_of_iter: ('a, 'c) iter -> 'c -> 'a list (**[elements_of_foldr] transforms an iteration function [foldr] into an [elements] function, which returns the list of the elements of a collection. *) val elements_of_foldr: ('a, 'a list, 'c) foldr -> 'c -> 'a list (**[elements_of_foldl] transforms an iteration function [foldl] into an [elements] function, which returns the list of the elements of a collection. *) val elements_of_foldl: ('a, 'a list, 'c) foldl -> 'c -> 'a list (**[elements_of_iteri] transforms an iteration function [iteri] into an [elements] function, which returns the list of key-value pairs of a collection. *) val elements_of_iteri: ('a, 'b, 'c) iteri -> 'c -> ('a * 'b) list (**[elements_of_foldri] transforms an iteration function [foldri] into an [elements] function, which returns the list of key-value pairs of a collection. *) val elements_of_foldri: ('a, 'b, ('a * 'b) list, 'c) foldri -> 'c -> ('a * 'b) list (**[elements_of_foldli] transforms an iteration function [foldli] into an [elements] function, which returns the list of key-value pairs of a collection. *) val elements_of_foldli: ('a, 'b, ('a * 'b) list, 'c) foldli -> 'c -> ('a * 'b) list end end (* -------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------- *) (* LocalWords: PPrint nondet deconstructible deconstructible resizeable exn *) (* LocalWords: Gen.sequential exn seq map_outof uncurry ifpol oneshot *) (* LocalWords: dprintf section:gen parenthesized customized *) (* LocalWords: well-formedness Gen.closed_interval *) monolith-20250314/src/Ops.ml000066400000000000000000000052741476503452400155110ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Error open Spec (* The engine needs a description of the operations. *) (* However, the engine doesn't have to be a functor. We expose a function that allows the user to declare the existence of an operation; that's enough. *) (* [operations] is a list of the operations that have been declared so far. *) let operations : (string * value) list ref = ref [] (* As soon as [pick] is called, the list of operations becomes frozen. The specifications are normalized, and the list is turned into an array, for efficiency. If [frozen] is [Some _], then the operations are frozen. *) let frozen : (string * value) array option ref = ref None (* Declare these two pieces of state, so they can be re-initialized at the beginning of each run. *) let () = GlobalState.register_ref operations; GlobalState.register_ref frozen (* [declare name spec reference candidate] declares the existence of an operation. Its parameters are the operation's name (used for printing), the operation's specification, and the reference/candidate implementations of this operation. *) let declare name spec rv cv = match !frozen with | Some _ -> error "cannot use Monolith.declare after Monolith.main has been called." | None -> operations := (name, Value (spec, rv, cv)) :: !operations (* [pick] freezes the set of operations, if necessary, and picks an operation from this set. *) let rec pick () = match !frozen with | Some operations -> let n = Array.length operations in if n > 0 then operations.(Gen.int n ()) else (* Likely a user error. *) error "no operations have been declared." | None -> frozen := Some (Array.map normalize_op (Array.of_list !operations)); pick() monolith-20250314/src/Ops.mli000066400000000000000000000023401476503452400156510ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Spec (* See Monolith.mli for documentation. *) val declare : string -> ('r, 'c) spec -> 'r -> 'c -> unit (* [pick()] chooses an operation among those that have been declared. It returns a pair of the operation's name and value. *) val pick: unit -> string * value monolith-20250314/src/Print.ml000066400000000000000000000044551476503452400160440ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) include PPrint type 'a printer = 'a -> document let block doc = nest 2 (break 0 ^^ doc) ^^ break 0 let parens doc = lparen ^^ block doc ^^ rparen let raw_apply docs = group (flow (break 1) docs) let apply doc docs = raw_apply (doc :: docs) let toplevel_let pat body = group ( utf8string "let " ^^ pat ^^ utf8string " =" ^^ nest 2 (break 1 ^^ body) ^^ utf8string ";;" ) let output b doc = ToBuffer.pretty 0.9 78 b (group doc) let unit = !^ "()" let bool = OCaml.bool let exn e = !^ (Printexc.to_string e) let char = OCaml.char let string = OCaml.string let int i = utf8format (if i < 0 then "(%d)" else "%d") i let option f = function | None -> !^ "None" | Some x -> parens (!^ "Some " ^^ f x) let result f1 f2 = function | Ok x -> parens (!^ "Ok " ^^ f1 x) | Error x -> parens (!^ "Error " ^^ f2 x) let either f1 f2 = function | Either.Left x -> parens (!^ "Either.Left " ^^ f1 x) | Either.Right x -> parens (!^ "Either.Right " ^^ f2 x) let pair f1 f2 (x1, x2) = OCaml.tuple [ f1 x1; f2 x2 ] let list = OCaml.flowing_list let array = OCaml.flowing_array let comment doc = group ( break 1 ^^ !^ "(* " ^^ doc ^^ !^ " *)" ) let candidate_finds doc = comment (!^ "candidate finds " ^^ doc) let assert_ doc = apply (!^ "assert") [ parens doc ] monolith-20250314/src/Spec.ml000066400000000000000000000427231476503452400156420ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Code (* -------------------------------------------------------------------------- *) (** When the combinator [nondet] is used, the reference implementation has access to a result of type ['c] produced by the candidate implementation. It must either accept the candidate's result and produce its own result of type ['r], or reject the candidate's result and produce a piece of OCaml code that explains why this result is unacceptable. This code is represented by a function of type [document -> document]. It receives the name of a variable, such as [observed], which stands for the candidate's result. This code could be an OCaml assertion that the observed result does not satisfy, or it could be just a comment. *) type 'r diagnostic = | Valid of 'r | Invalid of (PPrint.document -> PPrint.document) (** In the common case where ['r] and ['c] are the same type, the following type abbreviation is useful. The reference implementation must produce a result of type ['r nondet] instead of just ['r]. *) type 'r nondet = 'r -> 'r diagnostic (* -------------------------------------------------------------------------- *) (* A value of type [('r, 'c) spec] is a runtime representation of a specification. This specification describes an operation whose type in the reference implementation is ['r] and whose type in the candidate implementation is ['c]. *) (* In other words, a specification can be thought of a binary (or relational) type, in contrast with the more common unary types that describe a single value. *) (* -------------------------------------------------------------------------- *) (* The data constructors of the type [(_, _) spec] can be organized in several groups: 1. The data constructors for "positive" data, that is, data that can be constructed and deconstructed -- typically most data except functions. 2. The data constructors for "negative" data, typically functions, which cannot be constructed or deconstructed, but can be used (applied). 3. [SpecMapOutof] describes data that can be constructed, but not deconstructed or used in any way. 4. [SpecIfPol] is eliminated by [normalize]. 5. [SpecDeferred] allows constructing recursive (cyclic) specifications. *) type (_, _) spec = (* 1. Positive data. *) (* A constructible type is an OCaml type that is equipped with a generator. This must be a concrete type: the types ['r] and ['c] must coincide. *) | SpecConstructible : { generate : unit -> 't code } -> ('t, 't) spec (* An abstract base type has possibly different representations in the reference and candidate implementations. Its values are opaque (not observable). A tag allows testing at runtime whether two abstract base types are equal; this is used when one wishes to select a variable of appropriate type in the environment. *) (* We associate this tag with the product type ['r * c] so that the dynamic equality of two tags will imply a static type equality both on the reference side and on the implementation side. This is a situation where the injectivity of the product type is exploited: the equality of two product types implies the equality of their components. *) | SpecBaseAbstract: ('r * 'c) Tag.tag * ('r, 'c) abstract -> ('r, 'c) spec (* Unit. *) | SpecUnit: (unit, unit) spec (* Pairs. *) | SpecPair : ('r1, 'c1) spec * ('r2, 'c2) spec -> ('r1 * 'r2, 'c1 * 'c2) spec (* Options. *) | SpecOption : ('r, 'c) spec -> ('r option, 'c option) spec (* Results. *) | SpecResult : ('r1, 'c1) spec * ('r2, 'c2) spec -> (('r1, 'r2) result, ('c1, 'c2) result) spec (* The type [either] is isomorphic to [result]. *) | SpecEither : ('r1, 'c1) spec * ('r2, 'c2) spec -> (('r1, 'r2) Either.t, ('c1, 'c2) Either.t) spec (* Lists. *) | SpecList: int Gen.gen * ('r, 'c) spec -> ('r list, 'c list) spec (* A subset specification [Spec (spec, p)] restricts the specification [spec] to the subset of the values that satisfy the predicate [p]. Technically, the predicate [p] applies to a reference-side value. This is again justified by the fact that we want to rely on the reference implementation when we determine which arguments are acceptable for an operation. *) (* This feature is typically used to require an argument of abstract type to satisfy a precondition. It can also be used at a concrete type, but this is not recommended, as one usually prefers to generate a suitable value directly, rather than first generate a possibly-unsuitable value and then eliminate it. *) | SpecSubset : ('r, 'c) spec * ('r -> bool) -> ('r, 'c) spec (* The mark [SpecNondet] is used to annotate the return type of an operation whose *specification* is nondeterministic. This indicates that several results are permitted; therefore, one cannot expect the reference implementation to produce "the" expected result. Instead, one must run the candidate implementation first, and give the reference implementation access to the result produced by the candidate. In many (albeit not all) situations, this is sufficient for the reference implementation to determine how it must behave. *) | SpecNondet : ('r, 'c) spec -> ('c -> 'r diagnostic, 'c) spec (* 2. Negative data. *) (* A deconstructible type is an OCaml type that is equipped with an equality test and a printer. This must be a concrete type: the types ['r] and ['c] must coincide. *) | SpecDeconstructible : { equal : ('t -> 't -> bool) code; print : 't -> PPrint.document } -> ('t, 't) spec (* [SpecTop] describes an output that must be ignored. *) | SpecTop : ('r, 'c) spec (* Arrows. *) | SpecArrow : ('r1, 'c1) spec * ('r2, 'c2) spec -> ('r1 -> 'r2, 'c1 -> 'c2) spec (* A dependent arrow allows the codomain to depend on a value of the domain. This allows naming an argument and referring to this name in the rest of the specification. Technically, the codomain depends on a value of type ['r1], the left projection of the domain. This is justified by the fact that we want to rely on the reference implementation when we determine which arguments are acceptable for an operation. *) | SpecDependentArrow : ('r1, 'c1) spec * ('r1 -> ('r2, 'c2) spec) -> ('r1 -> 'r2, 'c1 -> 'c2) spec (* [SpecMapInto] indicates that the user provides a value of type ['r1, 'c1] but wishes it to be transformed on the fly to a value of type ['r2, 'c2]. To do so, the user provides a wrapper. Technically, the user must provide the name of this wrapper as well as its implementation on each side. The user also provides a description of the destination type, hence the name [SpecMapInto]. *) | SpecMapInto : ('r1 -> 'r2) * ('c1 -> 'c2) code * ('r2, 'c2) spec -> ('r1, 'c1) spec (* 3. Special case. *) (* [SpecMapOutof] indicates that the user provides a value of type ['r1, 'c1] but wishes it to be transformed on the fly to a value of type ['r2, 'c2]. To do so, the user provides a wrapper. Technically, the user must provide the name of this wrapper as well as its implementation on each side. The user also provides a description of the source type, hence the name [SpecMapOutof]. *) | SpecMapOutof : ('r1 -> 'r2) * ('c1 -> 'c2) code * ('r1, 'c1) spec -> ('r2, 'c2) spec (* 4. Special cases. *) (* [SpecIfPol (neg, pos)] is a specification that is interpreted differently depending on whether it appears in a negative or positive position. *) | SpecIfPol : ('r, 'c) spec * ('r, 'c) spec -> ('r, 'c) spec (* [SpecDeferred] allows constructing recursive (cyclic) specifications. *) | SpecDeferred : ('r, 'c) spec Lazy.t -> ('r, 'c) spec (* -------------------------------------------------------------------------- *) (* The following information is associated with an abstract base type. *) and ('r, 'c) abstract = { (* The base name used for a variable of this type. *) aty_var : string; (* A [check] function used to the check the well-formedness of a value of this type. *) aty_check : 'r -> ('c -> unit) code; } (* -------------------------------------------------------------------------- *) (* Constructor functions. *) (* Short public names for the constructors above. *) let unit = SpecUnit let ( *** ) first second = SpecPair (first, second) let pair = ( *** ) let option spec = SpecOption spec let result spec1 spec2 = SpecResult (spec1, spec2) let either spec1 spec2 = SpecEither (spec1, spec2) let list ?length:(length=Gen.lt 16) spec = SpecList (length, spec) let ignored = SpecTop let (^>) domain codomain = SpecArrow (domain, codomain) let (^>>) domain codomain = SpecDependentArrow (domain, codomain) let (%) p spec = SpecSubset (spec, p) let nondet spec = SpecNondet spec let map_into rwrap cwrap spec = SpecMapInto (rwrap, cwrap, spec) let map_outof rwrap cwrap spec = SpecMapOutof (rwrap, cwrap, spec) let ifpol neg pos = SpecIfPol (neg, pos) let fix f = let rec spec = SpecDeferred (lazy (f spec)) in spec let constructible (generate : unit -> 't code) = SpecConstructible { generate } let easily_constructible (generate : unit -> 't) (print : 't -> PPrint.document) = let generate () = let value = generate() in value, Code.document (print value) in constructible generate let deconstructible ?equal:(equal=((=), Code.infix "=")) print = SpecDeconstructible { equal; print } (* -------------------------------------------------------------------------- *) (* A value is a triple of a runtime type representation, a reference value, and a candidate value. *) type value = | Value : ('r, 'c) spec * 'r * 'c -> value (* -------------------------------------------------------------------------- *) (* [declare_abstract_type] extends the type [spec] with a new case. The new type is regarded as abstract: its representation is [r] in the reference implementation and [c] in the candidate implementation. The new data constructor has type [(r, c) spec]. *) let default_check : type r c . r -> (c -> unit) code = fun _ -> (fun _ -> ()), Code.constant "(fun _ -> ())" let default_var = "x" let declare_abstract_type ?check:(check=default_check) ?var:(var=default_var) () = (* Create a new tag for this abstract type. *) let tag = Tag.new_tag () in (* Done. *) SpecBaseAbstract (tag, { aty_var = var; aty_check = check }) (* -------------------------------------------------------------------------- *) (* [normalize op polarity order_zero gen spec] checks that the specification [spec] is well-formed and normalizes it. *) (* If the specification is ill-formed, the exception [IllFormedSpec] is raised. It is important to note that, because of [SpecDependentArrow], this exception is not necessarily raised when [normalize] is invoked; it can also be raised later on, when the normalized specification is used. *) (* [op] is the name of the operation whose specification this is. *) (* A positive [polarity] indicates an output; a negative polarity indicates an input. Because higher-order function types are not permitted, a positive polarity actually means that we are in a strictly positive position (that is, under zero arrows). Conversely, a negative polarity indicates that we are under exactly one arrow and therefore an order-0 type is expected. *) (* The flag [order_zero] indicates that an order-0 type is expected, i.e., arrows and dependent arrows are forbidden. Negative polarity implies [order_zero], but the converse is not true: order-0 is also required under a pair. *) exception IllFormedSpec of (* operation, message: *) string * string let ill_formed op format = Printf.ksprintf (fun s -> raise (IllFormedSpec (op, s))) format let rec normalize : type r c . string -> bool -> bool -> (r, c) spec -> (r, c) spec = fun op polarity order_zero spec -> match spec with | SpecConstructible _ -> if polarity then ill_formed op "A constructible type cannot be used in a positive position."; spec | SpecDeconstructible _ -> if not polarity then ill_formed op "A deconstructible type cannot be used in a negative position."; spec | SpecBaseAbstract _ -> spec | SpecUnit -> spec | SpecPair (first, second) -> (* Under a pair, we expect an order-0 type. *) let order_zero = true in let first = normalize op polarity order_zero first and second = normalize op polarity order_zero second in SpecPair (first, second) | SpecOption spec -> (* Under an option, we expect an order-0 type. *) let order_zero = true in let spec = normalize op polarity order_zero spec in SpecOption spec | SpecResult (spec1, spec2) -> let order_zero = true in let spec1 = normalize op polarity order_zero spec1 and spec2 = normalize op polarity order_zero spec2 in SpecResult (spec1, spec2) | SpecEither (spec1, spec2) -> let order_zero = true in let spec1 = normalize op polarity order_zero spec1 and spec2 = normalize op polarity order_zero spec2 in SpecEither (spec1, spec2) | SpecList (n, spec) -> let order_zero = true in let spec = normalize op polarity order_zero spec in SpecList (n, spec) | SpecTop -> if not polarity then ill_formed op "The combinator `ignored` cannot be used in a negative position."; SpecTop | SpecArrow (domain, codomain) -> if order_zero then ill_formed op "The combinator `^>` cannot be used in the left-hand side\n\ of a function or under a pair."; let domain = normalize op (not polarity) true domain and codomain = normalize op polarity order_zero codomain in SpecArrow (domain, codomain) | SpecDependentArrow (domain, codomain) -> if order_zero then ill_formed op "The combinator `^>>` cannot be used in the left-hand side\n\ of a function or under a pair."; let domain = normalize op (not polarity) true domain (* Here, normalization is deferred until the moment where an actual argument is provided. Therefore, it is also repeated, every time an actual argument is provided. An alternative approach might be to generate an actual argument once, just for the purposes of normalizing and checking the codomain. However, not every type supports generation (in an empty environment); abstract types do not. *) and codomain rv = normalize op polarity order_zero (codomain rv) in SpecDependentArrow (domain, codomain) | SpecSubset (spec, p) -> if polarity then ill_formed op "The combinator `%%` cannot be used in a positive position."; let spec = normalize op polarity order_zero spec in SpecSubset (spec, p) | SpecNondet spec -> if not polarity then ill_formed op "The combinator `nondet` cannot be used in a negative position."; let spec = normalize op polarity order_zero spec in SpecNondet spec | SpecMapInto (rwrap, cwrap, spec) -> if not polarity then ill_formed op "The combinator `map_into` (%s) \ cannot be used in a negative position." (Code.string cwrap); let spec = normalize op polarity order_zero spec in SpecMapInto (rwrap, cwrap, spec) | SpecMapOutof (rwrap, cwrap, spec) -> if polarity then ill_formed op "The combinator `map_outof` (%s) \ cannot be used in a positive position." (Code.string cwrap); let spec = normalize op polarity order_zero spec in SpecMapOutof (rwrap, cwrap, spec) | SpecIfPol (neg, pos) -> normalize op polarity order_zero (if polarity then pos else neg) | SpecDeferred spec -> (* One might wish for [normalize] to eliminate [SpecDeferred]. However, doing this, while guaranteeing termination, would require some form of marking. For greater simplicity, we keep it and perform on-demand normalization. This means that we perform redundant normalization work as we iterate along a cycle. *) SpecDeferred (lazy (normalize op polarity order_zero (Lazy.force spec))) let normalize op spec = let polarity = true and order_zero = false in normalize op polarity order_zero spec let normalize_op (op, Value (spec, rv, cv)) = (op, Value (normalize op spec, rv, cv)) monolith-20250314/src/Support.ml000066400000000000000000000243221476503452400164170ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) (* This module offers utility functions that can play a role in scenarios. This means that we must make them available to the user. A simple-minded approach would be to print their definitions as part of error scenarios. It seems preferable to just make them available as part of the Monolith API, so the user can type [#require "monolith";;] in the OCaml REPL and has access to all functions in [Monolith.Support]. *) (* We define [Sup] as a short name for [Monolith.Support] at the beginning of every scenario. This is done in [Engine.main]. *) let support name = Code.constant ("Sup." ^ name) (* -------------------------------------------------------------------------- *) module Tuple = struct (* Converting a triple to nested pairs, and back. *) let unnest3 (x, (y, z)) = (x, y, z) let nest3 (x, y, z) = (x, (y, z)) module Unnest3 = struct let appearance = support "Tuple.unnest3" let code = unnest3, appearance end module Nest3 = struct let appearance = support "Tuple.nest3" let code = nest3, appearance end end (* -------------------------------------------------------------------------- *) module Fun = struct let id x = x module Id = struct let appearance = support "Fun.id" (* The following is an optional optimization: when [id] is applied to at least one argument, we can perform beta-reduction on the fly, so that the application of [id] becomes invisible. *) let appearance = Code.custom (fun actuals -> match actuals with | x :: more -> Print.apply x more | _ -> Code.apply appearance actuals ) let code = id, appearance end let rot2 f y x = f x y module Rot2 = struct let appearance = support "Fun.rot2" (* The following is an optional optimization: when [rot2] is applied to at least three actual arguments, we can perform beta-reduction on the fly, so that the application of [rot2] becomes invisible. This is permitted, even though the actual arguments are not necessarily values, because [rot2] uses its arguments linearly and because we can assume that at most of one the arguments raises an exception. It is definitely a bit fragile. *) let appearance = Code.custom (fun actuals -> match actuals with | f :: y :: x :: more -> (* Someone who is crazy about detail will note that since [f] moves from argument position back to head position, it no longer needs to be parenthesized; but we have no way of removing parentheses. *) Print.apply f (x :: y :: more) | _ -> (* We have fewer than three actual arguments; revert to the normal appearance. *) Code.apply appearance actuals ) let code = rot2, appearance end let rot3 f z x y = f x y z module Rot3 = struct let appearance = support "Fun.rot3" let appearance = Code.custom (fun actuals -> match actuals with | f :: z :: x :: y :: more -> Print.apply f (x :: y :: z :: more) | _ -> Code.apply appearance actuals ) let code = rot3, appearance end let curry f x y = f (x, y) module Curry = struct let appearance = support "Fun.curry" let appearance = Code.custom (fun actuals -> match actuals with | f :: x :: y :: more -> Print.apply f (PPrint.OCaml.tuple [ x; y ] :: more) | _ -> Code.apply appearance actuals ) let code = curry, appearance end let uncurry f (x, y) = f x y module Uncurry = struct let appearance = support "Fun.uncurry" let code = uncurry, appearance end end (* -------------------------------------------------------------------------- *) (* Combinators to test [iter] and [fold] functions. *) module Iteration = struct type ('a, 'c) iter = ('a -> unit) -> 'c -> unit let elements_of_iter (iter : ('a, 'c) iter) (c : 'c) : 'a list = let xs = ref [] in let push x = xs := x :: !xs in iter push c; List.rev !xs module ElementsOfIter = struct let appearance = support "Iteration.elements_of_iter" let code = elements_of_iter, appearance end type ('a, 's, 'c) foldr = ('a -> 's -> 's) -> 'c -> 's -> 's let elements_of_foldr (foldr : ('a, 's, 'c) foldr) (c : 'c) : 'a list = let cons x xs = x :: xs in foldr cons c [] |> List.rev module ElementsOfFoldr = struct let appearance = support "Iteration.elements_of_foldr" let code = elements_of_foldr, appearance end type ('a, 's, 'c) foldl = ('s -> 'a -> 's) -> 's -> 'c -> 's let elements_of_foldl (foldl : ('a, 's, 'c) foldl) (c : 'c) : 'a list = let cons xs x = x :: xs in foldl cons [] c |> List.rev module ElementsOfFoldl = struct let appearance = support "Iteration.elements_of_foldl" let code = elements_of_foldl, appearance end type ('a, 'b, 'c) iteri = ('a -> 'b -> unit) -> 'c -> unit let elements_of_iteri (iteri : ('a, 'b, 'c) iteri) (c : 'c) : ('a * 'b) list = let xvs = ref [] in let push x v = xvs := (x, v) :: !xvs in iteri push c; List.rev !xvs module ElementsOfIteri = struct let appearance = support "Iteration.elements_of_iteri" let code = elements_of_iteri, appearance end type ('a, 'b, 's, 'c) foldri = ('a -> 'b -> 's -> 's) -> 'c -> 's -> 's let elements_of_foldri (foldri : ('a, 'b, 's, 'c) foldri) (c : 'c) : ('a * 'b) list = let cons x v xvs = (x, v) :: xvs in foldri cons c [] |> List.rev module ElementsOfFoldri = struct let appearance = support "Iteration.elements_of_foldri" let code = elements_of_foldri, appearance end type ('a, 'b, 's, 'c) foldli = ('s -> 'a -> 'b -> 's) -> 's -> 'c -> 's let elements_of_foldli (foldli : ('a, 'b, 's, 'c) foldli) (c : 'c) : ('a * 'b) list = let cons xvs x v = (x, v) :: xvs in foldli cons [] c |> List.rev module ElementsOfFoldli = struct let appearance = support "Iteration.elements_of_foldli" let code = elements_of_foldli, appearance end end (* -------------------------------------------------------------------------- *) module List = struct (* [List.to_seq] appears in OCaml 4.07. *) let to_seq = List.to_seq module ToSeq = struct let appearance = Code.constant "List.to_seq" let code = to_seq, appearance end (* [List.of_seq] appears in OCaml 4.07. *) let of_seq = List.of_seq module OfSeq = struct let appearance = Code.constant "List.of_seq" let code = of_seq, appearance end end (* -------------------------------------------------------------------------- *) module Exn = struct (* Catching all exceptions. *) let handle f x = try Ok (f x) with | Engine.PleaseBackOff -> raise Engine.PleaseBackOff | e -> Error e module Handle = struct let appearance = support "Exn.handle" let code = handle, appearance end end (* -------------------------------------------------------------------------- *) module Seq = struct include Seq (* One-shot functions. *) exception ForcedTwice let oneshot f = let forced = ref false in fun x -> if !forced then raise ForcedTwice; forced := true; f x (* Affine sequences. *) open Seq let rec affine xs = oneshot (fun () -> match xs() with | Nil -> Nil | Cons (x, xs) -> Cons (x, affine xs) ) let to_option xs = match xs() with | Nil -> None | Cons (x, xs) -> Some (x, xs) (* The composition [affine . List.to_seq]. *) let rec list_to_affine_seq (xs : 'a list) : 'a t = oneshot (fun () -> match xs with | [] -> Nil | x :: xs -> Cons (x, list_to_affine_seq xs) ) module ListToAffineSeq = struct let appearance = support "Seq.list_to_affine_seq" let code = list_to_affine_seq, appearance end end (* -------------------------------------------------------------------------- *) (* This is a variant of affine sequences where it is possible to test at runtime whether a sequence is valid (i.e., can still be forced). *) module VSeq = struct type 'a t = { force: unit -> 'a node; valid: unit -> bool } and 'a node = | Nil | Cons of 'a * 'a t let valid xs = xs.valid() exception ForcedTwice let oneshot f = let forced = ref false in let force x = if !forced then raise ForcedTwice; forced := true; f x and valid () = not !forced in { force; valid } let rec affine (xs : 'a Seq.t) : 'a t = oneshot (fun () -> match xs() with | Seq.Nil -> Nil | Seq.Cons (x, xs) -> Cons (x, affine xs) ) let to_option xs = match xs.force() with | Nil -> None | Cons (x, xs) -> Some (x, xs) let rec forget (xs : 'a t) : 'a Seq.t = fun () -> match xs.force() with | Nil -> Seq.Nil | Cons (x, xs) -> Seq.Cons (x, forget xs) end monolith-20250314/src/Tag.ml000066400000000000000000000036131476503452400154560ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Eq (* The type ['a tags] is declared as an extensible type. *) type 'a tags = .. (* The type ['a tag] is then declared as follows. In short, a value of type ['a tag] is a data constructor [Tag], together with a proof that this data constructor is a member of the type ['a tags]. This apparently convoluted declaration allows us to use [Tag] both for construction and for deconstruction. *) module type TAG = sig type t type 'a tags += Tag : t tags end type 'a tag = (module TAG with type t = 'a) let new_tag (type a) () : a tag = (* Extend the type [_ tags] with a new data constructor [Tag]. *) let module T = struct type t = a type _ tags += | Tag : a tags end in (* Return this module. *) (module T) exception RuntimeTagError let equal (type a1 a2) ((module A1) : a1 tag) ((module A2) : a2 tag) : (a1, a2) eq = match A1.Tag with | A2.Tag -> Eq | _ -> raise RuntimeTagError monolith-20250314/src/Tag.mli000066400000000000000000000030061476503452400156230ustar00rootroot00000000000000(******************************************************************************) (* *) (* Monolith *) (* *) (* François Pottier *) (* *) (* Copyright Inria. All rights reserved. This file is distributed under the *) (* terms of the GNU Lesser General Public License as published by the Free *) (* Software Foundation, either version 3 of the License, or (at your *) (* option) any later version, as described in the file LICENSE. *) (* *) (******************************************************************************) open Eq (** A tag of type ['a tag] is a runtime representation of the base type ['a]. *) type _ tag (** The function [new_tag] extends the type [tag] with a new inhabitant. *) val new_tag : unit -> 'a tag (** This exception is raised by [equal] in case of a tag mismatch. *) exception RuntimeTagError (** [equal tag1 tag2] compares the tags [tag1] and [tag2] for equality. If the comparison fails, the exception [RuntimeTagError] is raised. If it succeeds, a runtime witness of type equality is returned. *) val equal : 'a1 tag -> 'a2 tag -> ('a1, 'a2) eq monolith-20250314/src/dune000066400000000000000000000001631476503452400152640ustar00rootroot00000000000000(library (public_name monolith) (flags (:standard -w A-4-44-70 -g)) (libraries unix afl-persistent pprint) )