omake-0.10.3/0000755000175000017500000000000013177364666011336 5ustar gerdgerdomake-0.10.3/README.md0000644000175000017500000000050413177364665012613 0ustar gerdgerdomake ===== This is the new home of omake. Please see also the project page at http://projects.camlcity.org/projects/omake.html for downloads, and documentation. Resources: - Travis (Linux and Mac CI): https://travis-ci.org/ocaml-omake/omake - Appveyor (Windows CI): https://ci.appveyor.com/project/gerdstolpmann/omake omake-0.10.3/INSTALL0000644000175000017500000001056013177364665012370 0ustar gerdgerd-*- Mode: text; fill-column: 70 -*- UNIFIED BUILD SCRIPTS In version 0.10 the build scripts have changed a lot. In particular, the scripts have been unified and are now the same under Unix and Windows. Also, no external "make" or "nmake" utility is needed anymore. Under Unix, you can simply do now ./configure && make && make install to install omake. The "configure" script takes a few arguments, see "./configure -help" for a list. Under Windows, the equivalent is (and this actually also works under Unix): ocaml configure.ml ocaml build.ml ocaml build.ml -install The scripts are essentially the same, just wrapped in a little bit different way. INSTALLATION WITH EXPLICIT BOOTSTRAP omake is designed to build itself. Of course you must be wondering how we build in the first place! If you already have a working copy of omake (for instance, by downloading and installing it from somewhere else like omake.metaprl.org), you can skip the bootstrap, and directly run: ocaml build.ml -no-bootstrap which picks up the working copy of omake found in PATH. Otherwise, let's assume you do don't have omake already installed and you want to build it. -- Bootstrapping -- Bootstrapping is done with the script "make.ml", which is actually implementing most of the functionality of a traditional Unix "make" utility. With the help of "make.ml", you can build a limited version of omake that you can then use to complete the install. NOTE: The bootstrap uses the file src/Makefile with default options, like CC=cc. If something goes wrong, you can edit these files by hand to suit your taste. However, the src/Makefiles are generated, and they will be clobbered when you run omake for the first time. To be safe, if you decide to modify them, save your changes in some safe place, not /tmp. There is a build driver "build.ml" that runs "make.ml" with the right options: ocaml build.ml -no-bootstrap -build => Skip the bootstrap, and build omake with omake ocaml build.ml -auto-bootstrap -build => Do the bootstrap when necessary ocaml build.ml -force-bootstrap -build => Enforce the bootstrap The bootstrap is always followed by the regular omake build. -- Detailed configuration -- omake maintains its own detailed configuration in the file .config. This file is written at the beginning of the regular build, but once it exists, it is not overwritten. You can modify it as you need it. -- Environment -- Environment variables: - PREFIX (make all, make install) specifies the prefix for OMake installation (defaults to /usr/local) - LIBDIR (make all, make install) specifies the location for OMake library directory (defaults to $PREFIX/lib) - BINDIR (make install) specifies the location for OMake binaries (defaults to $PREFIX/bin) - INSTALL_ROOT (make install) specifies a "packaging root" for the installation. Namely, omake will be installed under $INSTALL_ROOT/$LIBDIR and $INSTALL_ROOT/$BINDIR, but the omake binary will be compiled to look for its files under $LIBDIR. Please note that the first time OMake is built, the PREFIX, LIBDIR and BINDIR variables are wrtten into the .config file in the root of the sources tree. If the .config file exists, then the variables present there have precedence over the environment variables. -- Win32 bootstrap -- Win32 is supported both for the MinGW and for the MSVC toolchains- The native Win32 build is faster than a Cygwin executable; it is recommended. However, no matter what you do, execution times on Win32 will be substantially longer than on Unix (I'm not sure why; I'm guessing that Win32 is a pig). NOTE: Note that if you call any native executable from a Cygwin shell, and you signal it (for example, with control-C), Cygwin immediately terminates the process. This is a well-known problem with Cygwin. It also means that when you abort omake from a Cygwin shell, it will not have a chance to save its work. Next time you run omake, it will have forgotten everything it did before you aborted it. Please complain to the Cygwin people at www.cygwin.com if you would like this to change. Please be nice. They already know about this issue. One way to avoid this problem is to run omake from a dos-prompt. You can also run osh in a console window if you want a usable shell. -- Finishing the install -- Do ocaml build.ml -install to install omake. omake-0.10.3/LICENSE0000644000175000017500000004310313177364665012343 0ustar gerdgerd GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) 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 this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. 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. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute 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 and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the 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 a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, 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. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE 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. 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 convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This 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 2 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, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision 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, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This 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. omake-0.10.3/LICENSE.OMake0000644000175000017500000000273013177364665013337 0ustar gerdgerd OMake terms and conditions. July 15, 2006 The OMake program is distributed under licensing terms described in each source file. Generally speaking, this means that one of three licenses are used. The libmojave library is distributed under the terms if the GNU Lesser General Public License (LGPL). See the file LICENSE.libmojave for more details. The OMake scripts are distributed under the terms of the MIT license. The MIT license applies only to the portion of OMake where the MIT license is specifically indicated in the source code. The OMake program is distributed under terms of the GNU General Public License as published by the Free Software Foundation, version 2 of the License. The license is distributed in the file LICENSE. In addition, as a special exception, the copyright holders give permission to link the code of portions of this program with the Objective Caml runtime, under certain conditions as described in each individual source file, and distribute linked combinations including the two. You must obey the GNU General Public License in all respects for all of the code used other than Objective Caml. If you modify file(s) with this exception, you may extend this exception to your version of the file(s), but you are not obligated to do so. If you do not wish to do so, delete this exception statement from your version. If you delete this exception statement from all source files in the program, then also delete it here. omake-0.10.3/ChangeLog0000644000175000017500000000013013177364665013101 0ustar gerdgerd2016-01-03 Gerd Stolpmann * Starting another changelog omake-0.10.3/ChangeLog_old.txt0000644000175000017500000001652413177364665014573 0ustar gerdgerdFor a more verbose changelog, see http://omake.metaprl.org/changelog.html OMake 0.9.8.6 [10/26/2010] - Added keyword and optional function arguments. - Added "program" syntax. - Added support for partial and curried function applications. - Added a high-quality C parser, LaTeX parser and LaTeX spellchecker - New functions added: localtime, gmtime, mktime, normalize-tm, utimes, digest-string, url-escaped, find-all, addprefixes - Numerous bugs fixed OMake 0.9.8.5 [08/07/2007] - Fixed Ctrl-C handling on Windows (with now correctly interrupt OMake) - Added .STATIC and .MEMO rules, allowing defining lazy computations and lazy memoization maps - Added export sections, making it much easier to manage variable scoping - Fields in sub-objects can now be referenced directly - Many new built-in and library functions - Significant bug-fixes OMake 0.9.8.4 [06/04/2007] - Fixed a file descriptor leak - A few other minor bug fixes OMake 0.9.8.3 [06/01/2007] OMake 0.9.8.2 [skipped] - Made it easy to define default ("implicit") rules for phony targets. - Detect case-insensitive filesystems on Unix-like operating systems (especially important under Mac OS X). - A number of performance improvements. - Documentation improvements. OMake 0.9.8.1 [03/16/2007] - Added a large number of new built-in and standard library functions - Extented the autocomfiguration section of the standard library - A number of improvements in the interactive osh shell. - A number of improvements in the library of standard build recipes - Documentation improvements. - A number of other improvements and bugfixes. OMake 0.9.8 [12/11/2006] - The conversion from OMake expressions to shell command lines went through a major redesign to make it more consistent and less ad-hoc. - OMake documentation was significantly reorganized. - OCaml build rules: Added experimental improved dependency scanner using the upcoming "ocamldep -modules" feature; added support for the Menhir parser-generator. - Added a number of new options to control OMake's output and verbosity; OMake is now more silent by default. - Many more improvements and bug fixes. OMake 0.9.6.9 [04/11/2006] - Significantly improved C++ support; minor improvements in OCaml support. - Significantly updated the default (sample) OMakefile. - Significantly improved the performance of the built-in find command. - Several other bug fixes and improvements. - A number of documentation fixes and improvements. OMake 0.9.6.8 [01/23/2006] - Fixed a bug in PATH-expansion for pipelines. - Improved the handling of the ".PHONY" nodes. - Added a remove-project-directories function. - Documentation fixes. - A few other bugfixes and improvements. OMake 0.9.6.7 [12/28/2005] - Added basic support for C++. - Portability improvements. - OCaml.om improvements. - Minor documentation fixes. - A few other bugfixes and improvements. OMake 0.9.6.6 [11/05/2005] - Made sure OMake compiles fine with both OCaml 3.08 and 3.09. - A few minor bugfixes and improvements. OMake 0.9.6.5 [09/14/2005] - Improved support for configure-style scripts. - LaTeX rules improvements. - Fixed the "which" function and ocamlfind support under Cygwin. - New built-in functions: get-registry (Windows-only), removeprefix, html-string. - Improved processing of complex shell pipelines. - A number of documentation fixes. - Numerous other bug fixes and improvements. OMake 0.9.6 [07/17/2005] - Added "static" sections that are evaluated once. - Added :value: dependencies, where a target depends on a computed value, rather than a file. - Changed the meaning of the .SCANNER rules. .SCANNER rules are now much more similar to normal rules. - Added file locking for the .omakedb and .omc files. - Fixed issues where files were being expanded during the string->array conversion. - Rule execution now fails when any shell command fails, even those in nested sections. - Regular expressions now handle \(...\) arguments correctly. Also, the lexer has better performance, searching is now roughly linear time. - Added .SUBDIRS bodies, which can be used instead of the OMakefile in a subdirectory. - Added the vmount function to define a "virtual mount" of one directory over another. - Better accessibility of the build rules and dependencies from OMake scripts. - Improved the latex-related rules. - The Map object is completely changed. - Other bug fixes and improvements. OMake 0.9.5 [skipped] OMake 0.9.4 [01/04/2005] - Portability improvements. OMake should now compile and work under Windows 2000, Windows NT and FreeBSD. A number of Windows-specific bugs are fixed. A Windows installer is added. - OMake now uses the built-in versions of the following commands: cp, mv, mkdir, rm, rmdir, chmod - Improvements to the filesystem watch functionality. In particular, the build will now restart if a change to one of the OMakefiles is detected. - Added a USE_OCAMLFIND variable that can be used to force or prohibit the usage of ocamlfind in a project (by default USE_OCAMLFIND is set to true iff the ocamlfind executable is found in path). - Added a "--force-dotomake" option to create all .omc and .omo files under $HOME/.omake/cache and a "--dotomake" option to specify an alternative to $HOME/.omake - Added :squash: dependencies (that specify that the dependency must be built, but when the dependency changes, it does not cause the target to be rebuilt). - OMake will now read ~/.omakeinit and ~/.omakerc files on startup. - Improved the latex-related rules. - Documentation improvements. - Bugs fixed: 142, 153, 311, 313, 314, 316, 332, 333, 339, 350, 360, 361, 366, 367, 368, 374, 375. See http://bugzilla.metaprl.org/buglist.cgi?bug_id=142,153,311,313,314,316,332,333,339,350,360,361,366,367,368,374,375 for details. OMake 0.9.3 [10/18/2004] - OMake now supports ocamlfind in its default configuration file (thanks to Bardur Arantsson for the initial patch). - OMake should now also work with OCaml 3.07 (in addition to 3.08). - A large number of bug fixes, including: o OMake should now compile correctly under Cygwin (thanks to Peter Jolly who provided the patch), o "double-colon" rules (that allow specifying multiple rules for the same target) should now work correctly, o kqueue-based file system monitoring (Mac OS X, FreeBSD) should now work correctly o array definitions should now work better. - Added a work around for the command line length limitation of lib.exe on Windows - Filesystem monitoring functionality now provides a choice whether to continue monitoring once the project is built successfully. OMake 0.9.2 [09/08/2004] - Bugs fixed: o "make install" will no longer create $HOME/.omake as root; o the -custom option is now a part of OCAML_BYTE_LINK_FLAGS and can be easily disabled; o omake should now allow specifying dependencies for the same file more than once. - The OMakeroot.src, OMakeroot.default and OMakefile.default are now under MIT license to allow users to freely borrow from them into their own omake build files. (The rest of OMake is still under GPL). - Fixed a number of typos and formatting errors in documentation. omake-0.10.3/CONTRIBUTORS.org0000644000175000017500000000026613177364665014007 0ustar gerdgerd Originally developed by Jason Hickey and Alex Norgin. Now maintained by Hongbo Zhang(bobzhang1988@gmail.com) Performance improvements by Gerd Stolpmann omake-0.10.3/omake.spec.in0000644000175000017500000000405613177364665013717 0ustar gerdgerdRelease: %{index}%{?dist} Summary: The omake build system. Name: omake URL: http://omake.metaprl.org/ Source0: %{name}-%{version}-%{index}.tar.gz License: GPL Group: Development/Tools BuildRoot: %{_tmppath}/%{name}-root BuildRequires: ocaml >= 3.09.2, make, fam-devel, readline-devel, ncurses-devel %define debug_package %{nil} %description OMake is a build system, similar to GNU make, but with many additional features, including: - Support for large projects spanning multiple directories; - Support for commands that produce several targets at once; - Fast, accurate, automated dependency analysis using MD5 digests; - Portability: omake provides a consistent interface on Win32 and on Unix systems including Linux, OSX, and Cygwin; - Builtin functions that provide the most common features of programs like grep, sed, and awk; - Active filesystem monitoring, where the build automatically restarts whenever you modify a source file. %prep %setup -q %build INSTALL_ROOT=$RPM_BUILD_ROOT\ PREFIX=%{_prefix}\ BINDIR=%{_bindir}\ LIBDIR=%{_libdir}\ make all %install rm -rf $RPM_BUILD_ROOT mkdir -p $RPM_BUILD_ROOT%{_bindir} mkdir -p $RPM_BUILD_ROOT%{_libdir}/omake INSTALL_ROOT=$RPM_BUILD_ROOT\ PREFIX=%{_prefix}\ BINDIR=%{_bindir}\ LIBDIR=%{_libdir}\ make install chmod +w $RPM_BUILD_ROOT/%{_bindir}/* %clean rm -rf $RPM_BUILD_ROOT %files %defattr(-,root,root) %doc LICENSE LICENSE.OMake doc/txt/omake-doc.txt doc/ps/omake-doc.ps doc/ps/omake-doc.pdf doc/webpage CHANGELOG.txt %attr(555,root,root) %{_bindir}/* %{_libdir}/omake %changelog * Thu Dec 11 2006 Aleksey Nogin [0.9.8-1] - Updated for the new doc file list and the lack of the man pages. * Thu Aug 16 2005 Aleksey Nogin - Updated to account for the new non-autoconf build style. * Mon Sep 9 2004 Aleksey Nogin - Added doc files. * Thu May 8 2003 Jason Hickey - Added cvs_realclean * Tue Apr 22 2003 Aleksey Nogin - Path updates * Tue Apr 22 2003 Jason Hickey - Initial build. omake-0.10.3/omake.aip0000644000175000017500000003224613177364665013133 0ustar gerdgerd omake-0.10.3/version.txt0000644000175000017500000000000713177364665013560 0ustar gerdgerd0.10.3 omake-0.10.3/OMakefile0000644000175000017500000003152313177364665013120 0ustar gerdgerd######################################################################## # Configuration. # ################################### # DEV MODE # Turn it off when release # BYTE_ENABLED=true # NATIVE_ENABLED=false ################################### open build/C open build/svn_realclean include mk/defaults include mk/make_gen BOOTDIR=$(dir boot) BUILDDIR=$(dir .) .PHONY: realclean clean install all main # # Location of the OCaml library # if $(not $(defined CAMLLIB)) CAMLLIB = $(dir $(string $(getenv CAMLLIB, $(getenv OCAMLLIB, $(OCAMLLIB))))) export # # Architecture-specific configuration # if $(equal $(OSTYPE), Win32) # # Extra options for the C compiler # if $(equal $(CCOMPTYPE), msvc) CFLAGS += /MT /DWIN32 /W4 export else CFLAGS += -DWIN32 -g -O2 -Wall -Wno-unused -isystem$(CAMLLIB) export # # Don't build man pages # MAN_ENABLED = false # # Always use threads # THREADS_ENABLED = true export else # # Extra options for the C compiler # CFLAGS += -g -O2 -Wall -Wno-unused # # We never need threads on Unix # THREADS_ENABLED = false export # # General options # SCANNER_MODE = error # # OCaml options # OCAMLFLAGS[] = -safe-string -g -w -a-40 if $(THREADS_ENABLED) OCAMLFLAGS += -thread export # # Support for profiling # if $(not $(defined NATIVE_PROFILE)) NATIVE_PROFILE = false export if $(NATIVE_PROFILE) OCAMLOPTFLAGS += -p -inline 0 CFLAGS += -pg if $(equal $(NATIVE_PROFILE), compact) OCAMLOPTFLAGS += -compact export export # # Libraries (without suffixes) # OCAML_OTHER_LIBS = unix if $(THREADS_ENABLED) OCAML_OTHER_LIBS += threads export # # C options # INCLUDES += $(CAMLLIB) . EXTRA_CLIBS[] = if $(READLINE_ENABLED) CFLAGS += $(READLINE_CFLAGS) EXTRA_CLIBS += $(READLINE_CLIBS) export if $(NCURSES_ENABLED) CFLAGS += $(NCURSES_CFLAGS) EXTRA_CLIBS += $(NCURSES_CLIBS) export if $(FAM_ENABLED) CFLAGS += $(FAM_CFLAGS) EXTRA_CLIBS += $(FAM_CLIBS) export OCAML_LINK_FLAGS = $(mapprefix -cclib, $(set $(EXTRA_CLIBS))) # # Name of the genmagic program # VERSION_TXT = $(file version.txt) GENMAGIC = $(file src/magic/omake_gen_magic) ######################################################################## # Clean up # CLEAN = rm -rf *.cm* *~ .\#* *.o *.obj *.a *.lib *.exe *.omc *.install *.tmp clean: $(CLEAN) boot .config.omc .config.local.omc .omakedb* mk/*.omc .omake omake-boot$(EXE) lib/*.default download if $(not $(defined FORCE_REALCLEAN)) FORCE_REALCLEAN = false export realclean: clean svn_realclean $(if $(FORCE_REALCLEAN), -f) -i .omakedb -i .omakedb.lock -i .config -i .config.local ######################################################################## # Source code # .SUBDIRS: src ######################################################################## # Packaging # .PHONY: rpm tar zip pkg dmg osxclean publish .PHONY: package VERSION=$(string $(cat version.txt)) BASENAME = omake-$(VERSION) PUBFILES[] = README.md README.WIN32 INSTALL LICENSE LICENSE.OMake ChangeLog ChangeLog_old.txt CONTRIBUTORS.org omake.spec omake.spec.in omake.aip version.txt OMakefile OMakeroot Makefile configure configure.ml build build.ml make make.ml src/OMakefile src/Makefile src/*/OMakefile src/*/*.ml src/*/*.mly src/*/*.mll src/*/*.mli src/*/*.h src/*/*.c src/env/omake_ast_parse.input lib/OMakefile.default lib/OMakeroot.default lib/OMakeroot.install lib/OMakeroot.om lib/Pervasives.install lib/Pervasives.om lib/boot/Default lib/boot/License lib/build/*.install lib/build/*.om lib/configure/*.install lib/configure/*.om lib/parse/C/*.install lib/parse/C/*.om lib/parse/LaTeX/*.install lib/parse/LaTeX/*.om lib/web/*.install lib/web/*.om mk/defaults mk/make_config mk/make_gen mk/osconfig_mingw.mk mk/osconfig_msvc.mk mk/osconfig_unix.mk doc/OMakefile doc/html/*.html doc/html/*.css doc/images/*.ai doc/images/*.eps doc/images/*.gif doc/images/*.psd doc/info/omake-doc.info doc/info/omake-doc.info-* doc/ps/omake-doc.pdf doc/src/*.hva doc/src/*.sty doc/src/*.tex doc/txt/omake-doc.txt bench/OMakefile bench/mandel/Test1 osx_resources/Description.plist osx_resources/Info.plist.in osx_resources/OMake.pmproj osx_resources/installer_files/License.txt osx_resources/installer_files/preflight osx_resources/installer_files/ReadMe.txt test/awk/Test2/stdout.expected test/awk/Test2/awk.osh test/awk/Test2/run.osh test/awk/Test3/stdout.expected test/awk/Test3/awk.osh test/awk/Test3/run.osh test/awk/Test1/stdout.expected test/awk/Test1/awk.osh test/awk/Test1/run.osh test/awk/Awk.out test/awk/Awk.in test/awk/Subst.in test/awk/Test4/Subst.in test/awk/Test4/Subst.out.expected test/awk/Test4/OMakeroot test/awk/Test4/OMakefile test/awk/Test4/run.osh test/syntax/Test2 test/syntax/Test3 test/syntax/Test1 test/exec/Test1/xxx test/exec/Test1/OMakeroot test/exec/Test1/OMakefile test/parse/C/Test2/test.c test/parse/C/Test2/OMakeroot test/parse/C/Test2/OMakefile test/parse/C/Test3/test.c test/parse/C/Test3/OMakeroot test/parse/C/Test3/OMakefile test/parse/C/Test1/test.c test/parse/C/Test1/OMakeroot test/parse/C/Test1/OMakefile test/parse/C/test2.c test/exn/Test2 test/exn/Test3/exn.om test/exn/Test3/run.osh test/exn/Test5 test/exn/Test4 test/vmount/Test1/src/foo.c test/vmount/Test1/src/OMakefile test/vmount/Test1/build/.dummy test/vmount/Test1/OMakeroot test/vmount/Test1/OMakefile test/simple/Test7 test/simple/Test2/a/x/.dummy test/simple/Test2/a/y/.dummy test/simple/Test2/OMakeroot test/simple/Test2/OMakefile test/simple/Test9 test/simple/Test10 test/simple/Test3/OMakeroot test/simple/Test3/OMakefile test/simple/Test5 test/simple/Test1/OMakeroot test/simple/Test1/OMakefile test/simple/Test12 test/simple/Test8/stdout.expected test/simple/Test8/simple.om test/simple/Test8/run.osh test/simple/Test11 test/simple/Test4/stdout.expected test/simple/Test4/simple.om test/simple/Test4/run.osh test/simple/Test6 test/diff.om test/targets/Test2/OMakeroot test/targets/Test2/OMakefile test/targets/Test3/OMakeroot test/targets/Test3/OMakefile test/targets/Test3/run.osh test/targets/Test5/OMakeroot test/targets/Test5/run.osh test/targets/Test1/OMakeroot test/targets/Test1/OMakefile test/targets/Test4/OMakeroot test/curry/Test2 test/curry/Test3 test/curry/Test5 test/curry/Test1 test/curry/Test4 test/object/Test13 test/object/Test09 test/object/Test10 test/object/Test17 test/object/Test18 test/object/Test15 test/object/Test16 test/object/Test11 test/object/Test03 test/object/Test14 test/object/Test05 test/object/Test07 test/object/Test06 test/object/Test04 test/object/Test08 test/object/Test02 test/object/Test01/stdout.expected test/object/Test01/OMakeroot test/object/Test01/OMakefile test/object/Test01/run.osh test/object/Test01/object.om test/regex/Test2 test/regex/Test3 test/regex/Test1 test/regex/Test4 test/memo/Test2/stdout.expected test/memo/Test2/OMakeroot test/memo/Test2/run.osh test/memo/Test3/stdout.expected test/memo/Test3/OMakeroot test/memo/Test3/run.osh test/memo/Test5/stdout.expected test/memo/Test5/run.osh test/memo/Test5/fib.om test/memo/Test1/stdout.expected test/memo/Test1/OMakeroot test/memo/Test1/run.osh test/memo/Test4/stdout.expected test/memo/Test4/memo.om test/memo/Test4/run.osh test/memo/Test6/test.om test/memo/Test6/OMakeroot test/OMakefile test/README test/lazy/Test1 test/return/Test2 test/return/Test1 test/static/Test2/stdout.expected test/static/Test2/OMakeroot test/static/Test2/run.osh test/static/Test3/stdout.expected test/static/Test3/OMakeroot test/static/Test3/run.osh test/static/Test1/stdout.expected test/static/Test1/OMakeroot test/static/Test1/run.osh test/calculator/Test test/calculator/Test.input1 test/calculator/Test.input2 test/keyword/Test2 test/keyword/Test3 test/keyword/Test5 test/keyword/Test1 test/keyword/Test4 test/keyword/Test6 test/shell/Test7/OMakeroot test/shell/Test2/stdout.expected test/shell/Test2/OMakeroot test/shell/Test2/OMakefile test/shell/Test2/run.osh test/shell/Test3/run.osh test/shell/Test5 test/shell/Test1/shell.om test/shell/Test1/run.osh test/shell/Test4/run.osh test/shell/Test6/run.osh PUBFILES_EXCLUDE[] = src/env/omake_ast_parse.mly src/libmojave/lm_thread_core.ml src/libmojave/lm_thread_pool.ml src/magic/omake_magic.ml src/shell/omake_shell_sys.ml package: packages/$(BASENAME).tar.gz packages/$(BASENAME): rm -rf packages/$(BASENAME) mkdir -p packages/$(BASENAME) foreach(pat => ..., $(PUBFILES)) files = $(glob $(pat)) foreach(file => ..., $(files)) if $(test -f $(file)) mkdir -p packages/$(BASENAME)/$(dirname $(file)) cp $(file) packages/$(BASENAME)/$(file) foreach(file => ..., $(PUBFILES_EXCLUDE)) rm -f packages/$(BASENAME)/$(file) packages/$(BASENAME).tar.gz: packages/$(BASENAME) section cd packages rm -f $(BASENAME).tar.gz tar czf $(BASENAME).tar.gz $(BASENAME) .PHONY: clean-package rm -rf packages/$(BASENAME) rm -f packages/$(BASENAME).tar.gz rpm: version.txt make_rpm make_checkout ./make_rpm dmg: version.txt ./make_dmg dmg pkg: version.txt ./make_dmg pkg osxclean: version.txt ./make_dmg clean omake.spec: omake.spec.in echo $"%define index $(RELEASE)" > $@ echo $"Version: $(VERSION)" >> $@ cat $< >> $@ .DEFAULT: omake.spec ######################################################################## # Documentation # .SUBDIRS: doc .PHONY: doc doc: doc/txt doc/info doc/html doc/tex ######################################################################## # Standard library # .SUBDIRS: $(subdirs C, lib) %.install: %.om $(GENMAGIC)$(EXE) $(VERSION_TXT) $(GENMAGIC) -o $@ --version $(VERSION_TXT) --root $< clean: $(CLEAN) STDLIBFILES = $(find lib -name *.om) INSTALLFILES = $(replacesuffixes .om, .install, $(STDLIBFILES)) STDLIBNAMES = $(removesuffix .om, $(in lib, $(STDLIBFILES))) BOOTFILES[] = lib/boot/License lib/boot/Default DEFAULTFILES[] = lib/OMakeroot.default lib/OMakefile.default lib/OMakeroot.default: $(BOOTFILES) fprint($@, $(OMakeroot)) lib/OMakefile.default: $(BOOTFILES) fprint($@, $(OMakefile)) ######################################################################## # Installation # all: $(DEFAULTFILES) $(INSTALLFILES) $(ROOT)/src/Makefile # omaketop omaketop: src/clib/clib.a src/libmojave/lm.cma src/front/frt.cma src/top/boot_repl.cma src/magic/magic.cma src/ast/ast.cma src/ir/ir.cma src/env/env.cma src/eval/eval.cma src/shell/shell.cma src/exec/exec.cma src/build/build.cma src/builtin/builtin.cma $(OCAMLC) -custom -verbose -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma unix.cma src/clib/clib.a src/libmojave/lm.cma src/front/frt.cma src/top/boot_repl.cma src/magic/magic.cma src/ast/ast.cma src/ir/ir.cma src/env/env.cma src/eval/eval.cma src/shell/shell.cma src/exec/exec.cma src/build/build.cma src/builtin/builtin.cma -cclib -lreadline topstart.cmo -o $@ omakeutop:src/clib/clib.a src/libmojave/lm.cma src/front/frt.cma src/top/boot_repl.cma src/magic/magic.cma src/ast/ast.cma src/ir/ir.cma src/env/env.cma src/eval/eval.cma src/shell/shell.cma src/exec/exec.cma src/build/build.cma src/builtin/builtin.cma src/top/myutop.cmo ocamlfind ocamlc -custom -o omakeutop -thread -linkpkg -linkall -predicates create_toploop \ -package compiler-libs.toplevel,utop src/clib/clib.a src/libmojave/lm.cma src/front/frt.cma src/top/boot_repl.cma src/magic/magic.cma src/ast/ast.cma src/ir/ir.cma src/env/env.cma src/eval/eval.cma src/shell/shell.cma src/exec/exec.cma src/build/build.cma src/builtin/builtin.cma -cclib -lreadline src/top/myutop.cmo install: $(DEFAULTFILES) $(INSTALLFILES) mkdir -p $(INSTALL_LIBDIR)/omake cp -f -m 444 $(DEFAULTFILES) $(INSTALL_LIBDIR)/omake/ foreach(name => ..., $(STDLIBNAMES)) node = $(file $(INSTALL_LIBDIR)/omake/$(name).om) mkdir -p $(dirof $(node)) cp -f -m 444 lib/$(name).install $(node) ######################################################################## # Testing # .PHONY: check bench .SUBDIRS: test bench omake-0.10.3/OMakeroot0000644000175000017500000000074413177364665013165 0ustar gerdgerd# # We want the ocamldep-omake to be accessible through the standard path. # PATH[] += $(dir ocamldep) # # Do not search elsewhere for standard libraries # OMAKEPATH[] = . $(dir lib) # # Include the standard configuration # include build/C include build/OCaml include build/LaTeX # # Include the definition functions # include boot/License include boot/Default # # Include configuration utilities # include configure/Configure # # Include the OMakefile # .SUBDIRS: . omake-0.10.3/Makefile0000644000175000017500000000134513177364665013000 0ustar gerdgerdOCAML = ocaml OCAMLFLAGS = -safe-string .PHONY: all bootstrap force-bootstrap install default clean doc package # # Bootstrap program is omake-boot # default: bootstrap bootstrap: $(OCAML) $(OCAMLFLAGS) build.ml -auto-bootstrap OCAML="$(OCAML)" force-bootstrap: $(OCAML) $(OCAMLFLAGS) build.ml -force-bootstrap OCAML="$(OCAML)" all: $(OCAML) $(OCAMLFLAGS) build.ml -build OCAML="$(OCAML)" install: all $(OCAML) $(OCAMLFLAGS) build.ml -install OCAML="$(OCAML)" clean: $(OCAML) $(OCAMLFLAGS) build.ml -clean OCAML="$(OCAML)" doc: OMAKELIB=`pwd`/lib ./src/main/omake doc # omake version is taken from the version.txt file! package: OMAKELIB=`pwd`/lib ./src/main/omake clean-package OMAKELIB=`pwd`/lib ./src/main/omake package omake-0.10.3/configure0000755000175000017500000000005113177364665013240 0ustar gerdgerd#! /bin/sh exec ocaml configure.ml "$@" omake-0.10.3/configure.ml0000644000175000017500000000617113177364665013655 0ustar gerdgerd(* This file is distributed under the terms and conditions of the GNU GPL (General Public License), as detailed in the file LICENSE. Copyright (C) 2016 by Gerd Stolpmann. *) (* Configuration script for omake *) #warnings "-3";; #load "str.cma";; #load "unix.cma";; open Printf let is_windows = Sys.os_type = "Win32" let path = if is_windows then let re = Str.regexp ";" in Str.split re (Sys.getenv "PATH") else let re = Str.regexp ":" in Str.split re (Sys.getenv "PATH") let find_in_path prog = let prog = if is_windows then prog ^ ".exe" else prog in List.find (fun p -> Sys.file_exists (Filename.concat p prog)) path let prefix = try ref (Filename.dirname (find_in_path "ocamlc")) with | Not_found -> prerr_endline "ocamlc not found; aborting"; exit 1 let bad_version1 = Str.regexp "^[0123]\\..*" let bad_version2 = Str.regexp "^4.0[012]\\..*" let check_ocaml_version() = let ch = Unix.open_process_in "ocamlc -version" in let line = input_line ch in let status = Unix.close_process_in ch in if status <> Unix.WEXITED 0 then failwith "Cannot run: ocamlc -version"; if Str.string_match bad_version1 line 0 || Str.string_match bad_version2 line 0 then failwith "The ocaml version is too old. Need at least 4.03"; () let gnu_re1 = Str.regexp "--\\([-A-Za-z0-9]+\\)=\\(.*\\)$" let gnu_re2 = Str.regexp "--\\([-A-Za-z0-9]+\\)$" let gnu_options argv = let argv = Array.to_list argv in let argv = List.mapi (fun i arg -> if i > 0 && Str.string_match gnu_re1 arg 0 then ["-" ^ Str.matched_group 1 arg; Str.matched_group 2 arg] else if i > 0 && Str.string_match gnu_re2 arg 0 then ["-" ^ Str.matched_group 1 arg ] else [arg] ) argv in Array.of_list (List.flatten argv) let main() = let no_readline = ref false in let no_ncurses = ref false in let no_fam = ref false in Arg.parse_argv (gnu_options Sys.argv) [ "-prefix", Arg.Set_string prefix, " Install prefix"; "-disable-readline", Arg.Set no_readline, " Disable readline support"; "-disable-ncurses", Arg.Set no_ncurses, " Disable ncurses support"; "-disable-fam", Arg.Set no_fam, " Disable FAM support"; ] (fun s -> raise(Arg.Bad ("Unexpected: " ^ s)) ) "usage: configure [options]"; check_ocaml_version(); let f = open_out ".preconfig" in fprintf f "public.PREFIX = %s\n\n" !prefix; List.iter (fun (disabled, name) -> fprintf f "# %s: %s\n" name (if disabled then "disabled" else "auto"); fprintf f "%spublic.%s = false\n\n" (if disabled then "" else "#") name; ) [ !no_readline, "READLINE_ENABLED"; !no_ncurses, "NCURSES_ENABLED"; !no_fam, "FAM_ENABLED"; ]; close_out f; printf "Wrote .preconfig\n%!"; (try Sys.remove ".config" with Sys_error _ -> () ) let () = try main() with | Failure msg | Arg.Bad msg | Arg.Help msg | Sys_error msg -> flush stdout; prerr_endline msg; flush stderr; exit 1 omake-0.10.3/build0000755000175000017500000000004513177364665012361 0ustar gerdgerd#! /bin/sh exec ocaml build.ml "$@" omake-0.10.3/build.ml0000644000175000017500000002620713177364665012775 0ustar gerdgerd(* This file is distributed under the terms and conditions of the GNU GPL (General Public License), as detailed in the file LICENSE. Copyright (C) 2016 by Gerd Stolpmann. *) (* Bootstrap build driver for omake *) (* You can override the commands ocaml, ocamlc, ocamlopt on the command-line, e.g. ocaml build.ml OCAML=myocaml *) #warnings "-3";; #load "str.cma";; #load "unix.cma";; open Printf module StrMap = Map.Make(String) module StrSet = Set.Make(String) let ocaml vars = try StrMap.find "OCAML" vars with Not_found -> "ocaml" let ocamlc vars = try StrMap.find "OCAMLC" vars with Not_found -> "ocamlc" let ocamlopt vars = try StrMap.find "OCAMLOPT" vars with Not_found -> "ocamlopt" let rec restart f arg = try f arg with | Unix.Unix_error(Unix.EINTR,_,_) -> restart f arg let rec fold_lines f number acc fh = match try let line = input_line fh in let n = String.length line in let line = if n > 0 && line.[n-1] = '\r' then String.sub line 0 (n-1) else line in Some line with End_of_file -> None with | Some line -> let acc' = f number line acc in fold_lines f (number+1) acc' fh | None -> acc let with_command cmd parse = let ch = Unix.open_process_in cmd in try let data = parse ch in let status = Unix.close_process_in ch in match status with | Unix.WEXITED 0 -> data | Unix.WEXITED n -> failwith ("Command exited with error: " ^ cmd) | _ -> failwith ("Command exited with signal: " ^ cmd) with | Unix.Unix_error(code,_,name) -> ignore(Unix.close_process_in ch); let prefix = if name = "" then "" else name ^ ": " in raise (Sys_error(prefix ^ Unix.error_message code)) let bytecomp_c_compiler_re = Str.regexp "^bytecomp_c_compiler: \\(.*\\)$" let ws_re = Str.regexp "[ \t]+" let ocaml_cc vars = try StrMap.find "OCAML_CC" vars with Not_found -> with_command "ocamlc -config" (fold_lines (fun i line acc -> if Str.string_match bytecomp_c_compiler_re line 0 then let full = Str.matched_group 1 line in let words = Str.split ws_re full in List.hd words else acc ) 1 "cc" ) let ocaml_cflags vars = try StrMap.find "OCAML_CFLAGS" vars with Not_found -> with_command "ocamlc -config" (fold_lines (fun i line acc -> if Str.string_match bytecomp_c_compiler_re line 0 then let full = Str.matched_group 1 line in let words = Str.split ws_re full in String.concat " " (List.tl words) else acc ) 1 "" ) let exec_command env prog args = try let cmd = String.concat " " (prog :: List.map Filename.quote (Array.to_list args)) in printf "%s\n%!" cmd; let env = Array.of_list (List.map (fun (n,v) -> n ^ "=" ^ v) env) in let env = Array.append env (Unix.environment()) in let args = Array.append [| prog |] args in let pid = Unix.create_process_env prog args env Unix.stdin Unix.stdout Unix.stderr in let _, st = Unix.waitpid [] pid in match st with | Unix.WEXITED 0 -> () | Unix.WEXITED n -> failwith ("Command exited with error: " ^ cmd) | _ -> failwith ("Command exited with signal: " ^ cmd) with | Unix.Unix_error(code,_,name) -> let prefix = if name = "" then "" else name ^ ": " in raise (Sys_error(prefix ^ Unix.error_message code)) let copy src dest = (* only for small files... *) let f_src = open_in_bin src in let n = in_channel_length f_src in let data = Bytes.create n in really_input f_src data 0 n; close_in f_src; let f_dest = open_out_bin dest in output f_dest data 0 n; flush f_dest; close_out f_dest let copy_executable src dest = let need_exe = Sys.file_exists (src ^ ".exe") in let with_exe file = if need_exe then file ^ ".exe" else file in let src = with_exe src in let dest = with_exe dest in copy src dest; Unix.chmod dest 0o755 let touch file = let f = open_out_gen [ Open_wronly; Open_append; Open_creat ] 0o666 file in close_out f let safe_mkdir file = try Unix.mkdir file 0o777 with | Unix.Unix_error(Unix.EEXIST,_,_) -> () let is_dir dir = (* Sys.file_exists (Filename.concat dir ".") - doesn't work under Windows *) try let st = Unix.stat dir in Unix.(st.st_kind = S_DIR) with | Unix.Unix_error _ -> false let rec find dir pattern = (* pattern: regexp of the files to match in this directory *) let re = Str.regexp pattern in let allfiles = Array.to_list (Sys.readdir dir) in let allpaths = List.map (Filename.concat dir) allfiles in let files = List.filter (fun n -> Str.string_match re n 0 ) allfiles in let paths = List.map (Filename.concat dir) files in let subdirs = List.filter is_dir allpaths in let subpaths = List.flatten (List.map (fun dir -> find dir pattern) subdirs) in paths @ subpaths let safe_remove path = try Sys.remove path with Sys_error _ -> () let safe_remove_list l = List.iter safe_remove l let system_re = Str.regexp "^system: \\(.*\\)$" let get_system vars = let cmd = sprintf "%s -config" (ocamlc vars) in with_command cmd (fold_lines (fun i line acc -> if Str.string_match system_re line 0 then Str.matched_group 1 line else acc ) 1 "unknown" ) let have_ocamlopt vars = let cmd = ocamlopt vars in Sys.command cmd = 0 let configure_bootstrap vars = safe_mkdir "boot"; copy "src/Makefile" "boot/Makefile"; touch "boot/Makefile.dep"; ( match get_system vars with | "mingw" | "mingw64" -> copy "mk/osconfig_mingw.mk" "boot/osconfig.mk" | "win32" | "win64" -> copy "mk/osconfig_msvc.mk" "boot/osconfig.mk" | _ -> copy "mk/osconfig_unix.mk" "boot/osconfig.mk" ); let ocaml_cc_val = ocaml_cc vars in let ocaml_cflags_val = ocaml_cflags vars in let f = open_out_gen [Open_wronly; Open_append; Open_binary] 0 "boot/osconfig.mk" in fprintf f "\n\n# additions from build.ml:\n"; fprintf f "OCAML_CC = %s\n" ocaml_cc_val; fprintf f "OCAML_CFLAGS = %s\n" ocaml_cflags_val; close_out f let make self makedir vars target = let dir = Filename.dirname self in let args = StrMap.fold (fun n v acc -> (n ^ "=" ^ v) :: acc) vars [] in let args_a = Array.of_list (Filename.concat dir "make.ml" :: "-C" :: makedir :: target :: args) in exec_command [] (ocaml vars) args_a let run_bootstrap self vars = configure_bootstrap vars; let vars = if have_ocamlopt vars then StrMap.add "PREFERRED" ".opt" (StrMap.add "OCAMLSUFFIX" ".opt" vars) else vars in make self "boot" vars "Makefile.dep"; make self "boot" vars "omake" let do_bootstrap self vars ty = match ty with | `Force -> run_bootstrap self vars; ("boot/omake", "src/main/prelim_omake") | `Disable -> ("omake", "omake") | `Auto -> if not (Sys.file_exists "boot/omake") && not (Sys.file_exists "boot/omake.exe") then run_bootstrap self vars; ("boot/omake", "src/main/prelim_omake") let run_omake omake env vars args = let args1 = StrMap.fold (fun n v acc -> (n ^ "=" ^ v) :: acc) vars [] in exec_command env omake (Array.of_list (args @ args1)) let do_action self vars action omake1 omake2 = let env = [ "OMAKEFLAGS", ""; "OMAKEPATH", "lib" ] in match action with | `Build -> if not (Sys.file_exists ".preconfig") then failwith "Unconfigured. Run the configure script first!"; touch ".config"; run_omake omake1 env vars [ "--dotomake"; ".omake"; "--force-dotomake"; "main" ]; (* Windows cannot replace running executables. Create a copy. *) if omake1 <> omake2 then copy_executable "src/main/omake" "src/main/prelim_omake"; run_omake omake2 env vars [ "--dotomake"; ".omake"; "--force-dotomake"; "all" ] | `Install -> run_omake omake2 env vars [ "--dotomake"; ".omake"; "--force-dotomake"; "install" ] | `Clean -> safe_remove ".config"; if Sys.file_exists "boot" then find "boot" ".*" |> safe_remove_list; find "." ".*\\.omc" |> safe_remove_list; find "src" ".*\\.cmi" |> safe_remove_list; find "src" ".*\\.cmo" |> safe_remove_list; find "src" ".*\\.cmx" |> safe_remove_list; find "src" ".*\\.o" |> safe_remove_list; find "src" ".*\\.cmxa" |> safe_remove_list; find "src" ".*\\.a" |> safe_remove_list; find "src" ".*\\.so" |> safe_remove_list; find "src" ".*\\.dll" |> safe_remove_list; find "src" ".*\\.exe" |> safe_remove_list; safe_remove "src/env/omake_ast_parse.mly"; safe_remove "src/libmojave/lm_thread_core.ml"; safe_remove "src/libmojave/lm_thread_pool.ml"; safe_remove "src/magic/omake_magic.ml"; safe_remove "src/shell/omake_shell_sys.ml"; safe_remove "src/main/omake"; safe_remove "src/main/prelim_omake"; safe_remove "src/main/osh"; safe_remove ".omakedb"; safe_remove ".omakedb.lock" let set_re = Str.regexp "^\\([^=]+\\)=\\(.*\\)$" let main() = let self = Sys.argv.(0) in let self = if Filename.is_relative self then Filename.concat (Sys.getcwd()) self else self in let bootstrap = ref `Auto in let action = ref `Build in let vars = ref StrMap.empty in let setvar name value = vars := StrMap.add name value !vars in Arg.parse [ "-force-bootstrap", Arg.Unit (fun () -> bootstrap := `Force), " do the bootstrap again"; "-no-bootstrap", Arg.Unit (fun () -> bootstrap := `Disable), " no bootstrap, instead use the omake from $PATH"; "-auto-bootstrap", Arg.Unit (fun () -> bootstrap := `Auto), " do the bootstrap if needed - this is the default"; "-build", Arg.Unit (fun () -> action := `Build), " action: build omake - this is the default"; "-install", Arg.Unit (fun () -> action := `Install), " action: install omake"; "-clean", Arg.Unit (fun () -> action := `Clean), " action: clean up"; ] (fun s -> if Str.string_match set_re s 0 then let name = Str.matched_group 1 s in let value = Str.matched_group 2 s in setvar name value else raise(Arg.Bad ("Don't know what to do with: " ^ s)) ) "ocaml build.ml [options] (var=value) ..."; let boot_omake, made_omake = if !action = `Clean then "", "" else do_bootstrap self !vars !bootstrap in do_action self !vars !action boot_omake made_omake let () = try main() with | Failure msg | Arg.Bad msg | Sys_error msg -> flush stdout; prerr_endline msg; flush stderr; exit 1 omake-0.10.3/make0000755000175000017500000000004413177364665012176 0ustar gerdgerd#! /bin/sh exec ocaml make.ml "$@" omake-0.10.3/make.ml0000644000175000017500000006515413177364665012617 0ustar gerdgerd(* This file is distributed under the terms and conditions of the GNU GPL (General Public License), as detailed in the file LICENSE. Copyright (C) 2016 by Gerd Stolpmann. *) (* Run this as: ocaml make.ml This is a little "make"-like utility. It is not fully implemented, and mainly intended to help building omake under Windows. *) (* TODO: - globbing for sources - emulate cp, rm, ln, echo for Windows - suffix substitution *) #warnings "-3";; #load "str.cma";; #load "unix.cma";; open Printf module StrMap = Map.Make(String) module StrSet = Set.Make(String) type exp_rule = { targets : string list; sources : string list; commands : string list; (* reverse order *) } type suffix_rule = { target_suffix : string; source_suffix : string; sfx_commands : string list; (* reverse order *) } type rule = | Explicit of exp_rule | DblColon of exp_rule | Suffix of suffix_rule type rules = { exp_rules : exp_rule StrMap.t; (* keyed by target *) dblcolon_rules : exp_rule list StrMap.t; (* keyed by target; rev order *) suffix_rules : suffix_rule list; enabled_suffixes : StrSet.t; phonies : StrSet.t; default : string list; } let empty_rules = { exp_rules = StrMap.empty; dblcolon_rules = StrMap.empty; suffix_rules = []; enabled_suffixes = StrSet.empty; phonies = StrSet.empty; default = []; } type expr = | Concat of expr list | Literal of string | Variable of string | Shell of expr type varvalue = | Expanded of string | Unexpanded of expr type varmap = varvalue StrMap.t (* keyed by var name *) let debug_enabled = ref false let debug s = if !debug_enabled then print_endline s let catch_not_found f arg ~on_result ~on_not_found = match try Some(f arg) with Not_found -> None with | Some r -> on_result r | None -> on_not_found() let starts_with s u = let sl = String.length s in let ul = String.length u in sl >= ul && String.sub s 0 ul = u let multi_index s k charlist = let l = String.length s in let rec search k = if k >= l then raise Not_found; let c = s.[k] in if List.mem c charlist then k else search (k+1) in search k let read_data ch = (* textual data *) let buf = Buffer.create 1024 in try while true do let line = input_line ch in if Buffer.length buf > 0 then Buffer.add_char buf '\n'; let n = String.length line in if n > 0 && line.[n-1] = '\r' then Buffer.add_substring buf line 0 (n-1) else Buffer.add_string buf line done; assert false with | End_of_file -> Buffer.contents buf let ws_re = Str.regexp "[ \t\r\n]+" let wildcard_re = Str.regexp "\\*\\(\\.[a-zA-Z0-9]+\\)" let expand_command cmd = (* Windows shells do not expand wildcards, so we need to do it here. The following is super-primitive and only covers the form *.suffix. Quoting is not taken into account. *) if Sys.os_type = "Win32" then let words = Str.split ws_re cmd in if List.exists (fun w -> Str.string_match wildcard_re w 0) words then let words' = List.flatten (List.map (fun word -> if Str.string_match wildcard_re word 0 then let suffix = Str.matched_group 1 word in List.filter (fun file -> Filename.check_suffix file suffix) (Array.to_list(Sys.readdir ".")) else [word] ) words ) in String.concat " " words' else cmd else cmd let command_output cmd = let ch = Unix.open_process_in (expand_command cmd) in try let data = read_data ch in let status = Unix.close_process_in ch in match status with | Unix.WEXITED 0 -> data | Unix.WEXITED n -> failwith ("Command exited with error: " ^ cmd) | _ -> failwith ("Command exited with signal: " ^ cmd) with | Unix.Unix_error(code,_,name) -> ignore(Unix.close_process_in ch); let prefix = if name = "" then "" else name ^ ": " in raise (Sys_error(prefix ^ Unix.error_message code)) let rec eval_expr active env expr = match expr with | Concat l -> let l' = List.map (eval_expr active env) l in String.concat "" l' | Literal s -> s | Variable name -> if StrSet.mem name active then failwith ("Recursive variable: " ^ name); let value = try StrMap.find name env with Not_found -> try Expanded(Sys.getenv name) with Not_found -> Expanded "" in ( match value with | Expanded s -> s | Unexpanded expr -> eval_expr (StrSet.add name active) env expr ) | Shell expr -> let cmd = eval_expr active env expr in command_output cmd let rec parse_expr s = let l = String.length s in let literal_list k0 k1 = if k1 > k0 then [ Literal(String.sub s k0 (k1-k0)) ] else [] in let rec find_dollar delims onend acc k = let delimchars = List.map fst delims in catch_not_found (multi_index s k) ('$' :: delimchars) ~on_result:( fun d -> let c = s.[d] in if c = '$' then ( if d+1 >= l then failwith "Bad expression: '$' at end"; let litl = literal_list k d in let c = s.[d+1] in match c with | '$' -> let acc' = [ Literal "$" ] @ litl @ acc in find_dollar delims onend acc' (d+2) | '(' -> let acc' = litl @ acc in find_varend delims onend acc' ')' (d+2) | '{' -> let acc' = litl @ acc in find_varend delims onend acc' '}' (d+2) | _ -> let name = String.make 1 c in let acc' = [ Variable name ] @ litl @ acc in find_dollar delims onend acc' (d+2) ) else let litl = literal_list k d in let f = List.assoc c delims in f (litl @ acc) (d+1) ) ~on_not_found:( fun () -> let acc' = literal_list k l @ acc in onend acc' ) and find_varend old_delims old_onend acc cend k = catch_not_found (multi_index s k) [cend; ' '; '\t'; '('; '{'; '$'] ~on_result:( fun e -> let c = s.[e] in if c = cend then let name = String.sub s k (e-k) in let acc' = [ Variable name ] @ acc in find_dollar old_delims old_onend acc' (e+1) else match c with | ' ' | '\t' -> let name = String.sub s k (e-k) in if name = "shell" then let new_delims = [ cend, (fun subexpr p -> let acc' = Shell (Concat (List.rev subexpr)) :: acc in find_dollar old_delims old_onend acc' p ) ] @ old_delims in let new_onend _ = failwith "Bad expression: unterminated shell command" in find_dollar new_delims new_onend [] (e+1) else failwith ("Bad expression: unsupported function: " ^ name) | _ -> Printf.eprintf "Char: %c\n%!" c; failwith "Bad expression: variable ref contains bad char" ) ~on_not_found:(fun () -> failwith "Bad expression: unterminated variable ref" ) in find_dollar [] (fun l -> Concat(List.rev l)) [] 0 let expand env s = let expr = parse_expr s in eval_expr StrSet.empty env expr let ws_re = Str.regexp "^[ \t\t\n]*$";; let set_var_re = Str.regexp "^\\([^ +?=:]+\\)[ \t]*\\([:?+]?=\\)[ \t]*\\(.*\\)$" let dblcolon_rule_re = Str.regexp "^\\([^:]+\\)::\\(.*\\)$" let rule_re = Str.regexp "^\\([^:]+\\):\\(.*\\)$" let include_re = Str.regexp "^include[ \t]+\\([^ \t].*\\)$" let split_ws_re = Str.regexp "[ \t\r\n]+" let rec fold_lines fh f number acc = match try Some(input_line fh) with End_of_file -> None with | Some line -> let acc' = f number line acc in fold_lines fh f (number+1) acc' | None -> acc let update_env name op value env = match op with | "=" -> let expr = parse_expr value in StrMap.add name (Unexpanded expr) env | "?=" -> let expr = parse_expr value in if StrMap.mem name env then env else StrMap.add name (Unexpanded expr) env | "+=" -> let expr = parse_expr value in let old_value = match try StrMap.find name env with Not_found -> Unexpanded (Concat []) with | Unexpanded e -> e | Expanded s -> Literal s in let new_value = if old_value = Concat [] then expr else Concat [old_value; Literal " "; expr] in StrMap.add name (Unexpanded new_value) env | ":=" -> let expr = parse_expr value in let value = eval_expr StrSet.empty env expr in StrMap.add name (Expanded value) env | _ -> assert false let is_empty line = Str.string_match ws_re line 0 let append_to_rule rule line = match rule with | Explicit r -> Explicit { r with commands = line :: r.commands } | DblColon r -> DblColon { r with commands = line :: r.commands } | Suffix r -> Suffix { r with sfx_commands = line :: r.sfx_commands } let same_suffix_rule r1 r2 = r1.target_suffix = r2.target_suffix && r1.source_suffix = r2.source_suffix let enter_rule1 current env rules = match current with | None -> rules | Some (Explicit r) -> if r.commands = [] then List.fold_left (fun rules target -> if StrMap.mem target rules.dblcolon_rules then failwith "Cannot have both normal and double-colon rules for \ the same target"; if StrMap.mem target rules.exp_rules then (* add further dependencies to existing explicit rule *) let r1 = StrMap.find target rules.exp_rules in let r2 = { r1 with sources = r1.sources @ r.sources } in { rules with exp_rules = StrMap.add target r2 rules.exp_rules } else ( debug ("Enter " ^ target); (* add command-less rule *) { rules with exp_rules = StrMap.add target r rules.exp_rules } ) ) rules r.targets else ( (* new explicit rule *) List.iter (fun target -> if StrMap.mem target rules.dblcolon_rules then failwith "Cannot have both normal and double-colon rules for \ the same target"; try let r = StrMap.find target rules.exp_rules in if r.commands <> [] then failwith("Rule for target already exists: " ^ target); with Not_found -> () ) r.targets; List.fold_left (fun rules target -> debug ("Enter " ^ target); let r1 = try let r0 = StrMap.find target rules.exp_rules in { r with sources = r0.sources @ r.sources } with Not_found -> r in { rules with exp_rules = StrMap.add target r1 rules.exp_rules } ) rules r.targets ) | Some (DblColon r) -> let target = List.hd r.targets in (* only one target here *) if StrMap.mem target rules.exp_rules then failwith "Cannot have both normal and double-colon rules for the \ same target"; ( try let l = StrMap.find target rules.dblcolon_rules in { rules with dblcolon_rules = StrMap.add target (r :: l) rules.dblcolon_rules } with | Not_found -> { rules with dblcolon_rules = StrMap.add target [r] rules.dblcolon_rules } ) | Some (Suffix r) -> if List.exists (same_suffix_rule r) rules.suffix_rules then failwith ("Suffix rule already exists: " ^ r.source_suffix ^ r.target_suffix); { rules with suffix_rules = r :: rules.suffix_rules } let enter_rule current env rules = let rules = enter_rule1 current env rules in match current with | Some (Explicit r) when rules.default = [] -> { rules with default = r.targets } | _ -> rules let is_suffix_comb suffixes word = StrSet.fold (fun source_suffix acc -> match acc with | None -> if starts_with word source_suffix then let l1 = String.length source_suffix in let l2 = String.length word in let target_suffix = String.sub word l1 (l2-l1) in if StrSet.mem target_suffix suffixes then Some(target_suffix,source_suffix) else None else None | Some _ -> acc ) suffixes None let match_rule text = if Str.string_match dblcolon_rule_re text 0 then let target_str = Str.matched_group 1 text in let source_str = Str.matched_group 2 text in Some(`DblColon, target_str, source_str) else if Str.string_match rule_re text 0 then let target_str = Str.matched_group 1 text in let source_str = Str.matched_group 2 text in Some(`Colon, target_str, source_str) else None let process_rule env rules' ty target_str source_str = let target_words0 = Str.split split_ws_re target_str in (* not handled: glob expressions in sources *) ( match target_words0 with | [] -> failwith "Empty target" | [ ".PHONY" ] -> if ty = `DblColon then failwith ".PHONY not possible with double-colon rule"; let source_words = Str.split split_ws_re (expand env source_str) in let phonies = List.fold_left (fun acc phony -> StrSet.add phony acc) rules'.phonies source_words in let rules'' = { rules' with phonies } in ([],None,env,rules'') | [ ".SUFFIXES" ] -> if ty = `DblColon then failwith ".SUFFIXES not possible with double-colon rule"; let source_words = Str.split split_ws_re (expand env source_str) in let enabled_suffixes = List.fold_left (fun acc suffix -> StrSet.add suffix acc) rules'.enabled_suffixes source_words in let rules'' = { rules' with enabled_suffixes } in ([],None,env,rules'') | [ word ] when is_empty source_str -> ( match is_suffix_comb rules'.enabled_suffixes word with | Some(target_suffix, source_suffix) -> if ty = `DblColon then failwith "Suffix rule not possible with double-colon"; let r = { target_suffix; source_suffix; sfx_commands = [] } in ([],Some(Suffix r),env,rules') | None -> let r = { targets = Str.split split_ws_re (expand env word); sources = []; commands = [] } in let rule = match ty with | `Colon -> Explicit r | `DblColon -> DblColon r in ([],Some rule,env,rules') ) | _ -> let target_words = Str.split split_ws_re (expand env target_str) in let source_words = Str.split split_ws_re (expand env source_str) in if ty = `DblColon && List.length target_words > 1 then failwith "Only one target allowed for double-colon rule"; let r = { targets = target_words; sources = source_words; commands = [] } in let rule = match ty with | `Colon -> Explicit r | `DblColon -> DblColon r in ([],Some rule,env,rules') ) let rec parse_statements ?(exec = fun _ _ _ -> ()) env rules file = let fh = open_in file in let last_num = ref 0 in try let (preceding,current,env,rules) = fold_lines fh (fun number line (preceding,current,env,rules) -> last_num := number; let lline = String.length line in if preceding = [] && (is_empty line || line.[0] = '#') then (preceding,current,env,rules) else if line <> "" && line.[lline - 1] = '\\' then let data = String.sub line 0 (lline-1) in (data::preceding,current,env,rules) else let multiline = String.concat "" (List.rev (line :: preceding)) in if multiline.[0] = '\t' then match current with | None -> failwith "TAB found outside a rule definition" | Some rule -> let current' = Some (append_to_rule rule multiline) in ([],current',env,rules) else let rules' = enter_rule current env rules in if Str.string_match set_var_re multiline 0 then let name = Str.matched_group 1 multiline in let op = Str.matched_group 2 multiline in let value = Str.matched_group 3 multiline in let env' = update_env name op value env in ([],None,env',rules') else match match_rule multiline with | Some(ty, target_str, source_str) -> process_rule env rules' ty target_str source_str | None -> if Str.string_match include_re multiline 0 then ( let target = Str.matched_group 1 multiline in exec env rules target; let (env',rules'') = parse_statements ~exec env rules' target in ([],None,env',rules'') ) else failwith "Cannot parse line" ) 1 ([],None,env,rules) in if preceding <> [] then failwith "Last line ends with backslash"; let rules = enter_rule current env rules in (env, rules) with | Failure msg -> close_in fh; failwith ("File " ^ file ^ ", line " ^ string_of_int !last_num ^ ": " ^ msg) | error -> close_in fh; raise error let strip_spaces_re = Str.regexp "^[ \t]*\\(.*\\)$" let run_command1 cmd = if is_empty cmd then () else (* CHECK order: @- or -@ *) let no_echo, cmd1 = if cmd <> "" && cmd.[0] = '@' then true, String.sub cmd 1 (String.length cmd - 1) else false, cmd in let no_errcheck, cmd2 = if cmd1 <> "" && cmd1.[0] = '-' then true, String.sub cmd1 1 (String.length cmd1 - 1) else false, cmd1 in if not no_echo then print_endline cmd2; let code = Sys.command (expand_command cmd2) in if not no_errcheck && code <> 0 then failwith ("Command failed: " ^ cmd2) let run_command s = if Str.string_match strip_spaces_re s 0 then let cmd = Str.matched_group 1 s in run_command1 cmd else run_command1 s let exec made_targets env rules target = let rec make ancestors target = debug ("Make: " ^ target); if not (StrSet.mem target !made_targets) then ( match search_rule ancestors target with | Some list -> List.iter (fun (r,local_env) -> let env' = List.fold_left (fun acc (n,v) -> StrMap.add n v acc) env local_env in let ancestors' = StrSet.add target ancestors in List.iter (make ancestors') r.sources; let cmds1 = List.rev r.commands in let cmds2 = List.map (expand env') cmds1 in List.iter run_command cmds2; List.iter (fun tgt -> made_targets := StrSet.add tgt !made_targets ) r.targets ) list | None -> if StrSet.mem target rules.phonies then failwith("No way to execute phony target: " ^ target); if not(Sys.file_exists target) then failwith("No way to make target: " ^ target) ); debug ("Made: " ^ target); and search_rule ancestors target = if StrSet.mem target ancestors then None else try let r = StrMap.find target rules.exp_rules in if r.commands = [] then raise Not_found; let localenv = [ "@", (Expanded (String.concat " " r.targets)); "<", (Expanded (String.concat " " r.sources)); ] in debug (" target: " ^ target ^ " = direct"); Some [r, localenv] with | Not_found -> try (* Double-colon rules are always executed if r.sources=[]. Well, we always execute anyway, so this does not make a difference. *) let rlist = StrMap.find target rules.dblcolon_rules in debug (" target: " ^ target ^ " = double-colon"); Some (List.map (fun r -> let localenv = [ "@", (Expanded (String.concat " " r.targets)); "<", (Expanded (String.concat " " r.sources)); ] in (r,localenv) ) rlist ) with | Not_found -> search_implicit_rule ancestors target and search_implicit_rule ancestors target = debug (" target: " ^ target ^ " = search"); let r_opt = StrSet.fold (fun target_suffix rule_opt -> match rule_opt with | Some r -> Some r | None -> if Filename.check_suffix target target_suffix then ( debug(" target_suffix: " ^ target_suffix); let irules = List.filter (fun suffr -> suffr.target_suffix = target_suffix ) rules.suffix_rules in if irules = [] then None else ( let target_base = Filename.chop_suffix target target_suffix in try let ancestors' = StrSet.add target ancestors in let irule = List.find (fun suffr -> debug(" source_suffix: " ^ suffr.source_suffix); let source = target_base ^ suffr.source_suffix in search_rule ancestors' source <> None || Sys.file_exists source ) irules in let source = target_base ^ irule.source_suffix in let deps = try let r = StrMap.find target rules.exp_rules in r.sources with | Not_found -> [] in Some [ { targets = [target]; sources = source :: deps; commands = irule.sfx_commands }, [ "*", (Expanded target_base); "@", (Expanded target); "<", (Expanded source); ] ] with Not_found -> None ) ) else None ) rules.enabled_suffixes None in r_opt in try make StrSet.empty target with | Failure msg -> let d = Sys.getcwd() in failwith ("*** Error in directory " ^ d ^ ": " ^ msg) let set_re = Str.regexp "^\\([^=]+\\)=\\(.*\\)$" let main() = let self = Sys.argv.(0) in let self = if Filename.is_relative self then Filename.concat (Sys.getcwd()) self else self in let env = ref StrMap.empty in let targets = ref [] in let setvar name value = env := StrMap.add name (Expanded value) !env in Arg.parse [ "-C", Arg.String (fun s -> Sys.chdir s), " Change to this directory"; "-debug", Arg.Set debug_enabled, " Enable debug logging"; ] (fun s -> if Str.string_match set_re s 0 then let name = Str.matched_group 1 s in let value = Str.matched_group 2 s in setvar name value else targets := !targets @ [s] ) "ocaml make.ml [options] (var=value | target) ..."; setvar "MAKE" (sprintf "ocaml %s %s" self (if !debug_enabled then "-debug" else "") ); let made_targets = ref StrSet.empty in let (env,rules) = parse_statements ~exec:(exec made_targets) !env empty_rules "Makefile" in debug("Suffixes: " ^ String.concat "," (StrSet.elements rules.enabled_suffixes)); if !targets = [] then targets := rules.default; List.iter (exec made_targets env rules) !targets let () = try main() with | Failure msg | Arg.Bad msg | Sys_error msg -> flush stdout; prerr_endline msg; flush stderr; exit 1 omake-0.10.3/src/0000755000175000017500000000000013177364665012124 5ustar gerdgerdomake-0.10.3/src/OMakefile0000644000175000017500000000175013177364665013706 0ustar gerdgerd # # The order needs to be right in order for the bootstrapping Makefile to work. # ABORT_ON_DEPENDENCY_ERRORS = true # # Makefile.tmp care about the generated files. # .PHONY: MakefileDeps Makefile.tmp%: OCamlGeneratedFilesTarget MakefileDeps OldLocalOCamlGeneratedFiles = $(LocalOCamlGeneratedFiles) LocalOCamlGeneratedFiles(files) = MakefileDeps: $(files) OldLocalOCamlGeneratedFiles($(files)) export # # Subdirectories # .SUBDIRS: clib libmojave front magic LocalOCamlGeneratedFiles(magic/omake_magic.ml) .SUBDIRS: ir exec ast env LocalOCamlGeneratedFiles(env/omake_ast_lex.ml env/omake_ast_parse.mly env/omake_ast_parse.ml env/omake_ast_parse.mli) .SUBDIRS: shell eval build builtin main top # # Generate a Makefile # MakeRootMakefiles([...]) clib libmojave front magic ir exec ast env shell eval build builtin main # # Clean up # # TODO: clean omc, omakedb when adding a new directory clean: $(CLEAN) Makefile.tmp* omake-0.10.3/src/Makefile0000444000175000017500000014365013177364665013573 0ustar gerdgerd# # !!!THIS IS A GENERATED FILE!!! # !!!DO NOT MAKE CHANGES HERE, THEY WILL BE LOST!!! # include osconfig.mk OFILES_clib = c_lm_channel$(EXT_OBJ) c_lm_printf$(EXT_OBJ) c_lm_ctype$(EXT_OBJ) c_lm_uname_ext$(EXT_OBJ) c_lm_unix_cutil$(EXT_OBJ) c_lm_compat_win32$(EXT_OBJ) c_readline$(EXT_OBJ) c_omake_shell_sys$(EXT_OBJ) c_omake_shell_spawn$(EXT_OBJ) c_fam_win32$(EXT_OBJ) c_fam_kqueue$(EXT_OBJ) c_fam_inotify$(EXT_OBJ) c_lm_notify$(EXT_OBJ) c_lm_termsize$(EXT_OBJ) c_lm_terminfo$(EXT_OBJ) c_lm_fs_case_sensitive$(EXT_OBJ) clib$(EXT_LIB): $(OFILES_clib) -$(RM) $@ $(AR) $(AROUT)$@ $(OFILES_clib) c_lm_channel.c: ..$(slash)src$(slash)clib$(slash)lm_channel.c $(LN) ..$(slash)src$(slash)clib$(slash)lm_channel.c c_lm_channel.c c_lm_printf.c: ..$(slash)src$(slash)clib$(slash)lm_printf.c $(LN) ..$(slash)src$(slash)clib$(slash)lm_printf.c c_lm_printf.c c_lm_ctype.c: ..$(slash)src$(slash)clib$(slash)lm_ctype.c $(LN) ..$(slash)src$(slash)clib$(slash)lm_ctype.c c_lm_ctype.c c_lm_uname_ext.c: ..$(slash)src$(slash)clib$(slash)lm_uname_ext.c $(LN) ..$(slash)src$(slash)clib$(slash)lm_uname_ext.c c_lm_uname_ext.c c_lm_unix_cutil.c: ..$(slash)src$(slash)clib$(slash)lm_unix_cutil.c $(LN) ..$(slash)src$(slash)clib$(slash)lm_unix_cutil.c c_lm_unix_cutil.c c_lm_compat_win32.c: ..$(slash)src$(slash)clib$(slash)lm_compat_win32.c $(LN) ..$(slash)src$(slash)clib$(slash)lm_compat_win32.c c_lm_compat_win32.c c_readline.c: ..$(slash)src$(slash)clib$(slash)readline.c $(LN) ..$(slash)src$(slash)clib$(slash)readline.c c_readline.c c_omake_shell_sys.c: ..$(slash)src$(slash)clib$(slash)omake_shell_sys.c $(LN) ..$(slash)src$(slash)clib$(slash)omake_shell_sys.c c_omake_shell_sys.c c_omake_shell_spawn.c: ..$(slash)src$(slash)clib$(slash)omake_shell_spawn.c $(LN) ..$(slash)src$(slash)clib$(slash)omake_shell_spawn.c c_omake_shell_spawn.c c_fam_win32.c: ..$(slash)src$(slash)clib$(slash)fam_win32.c $(LN) ..$(slash)src$(slash)clib$(slash)fam_win32.c c_fam_win32.c c_fam_kqueue.c: ..$(slash)src$(slash)clib$(slash)fam_kqueue.c $(LN) ..$(slash)src$(slash)clib$(slash)fam_kqueue.c c_fam_kqueue.c c_fam_inotify.c: ..$(slash)src$(slash)clib$(slash)fam_inotify.c $(LN) ..$(slash)src$(slash)clib$(slash)fam_inotify.c c_fam_inotify.c c_lm_notify.c: ..$(slash)src$(slash)clib$(slash)lm_notify.c $(LN) ..$(slash)src$(slash)clib$(slash)lm_notify.c c_lm_notify.c c_lm_termsize.c: ..$(slash)src$(slash)clib$(slash)lm_termsize.c $(LN) ..$(slash)src$(slash)clib$(slash)lm_termsize.c c_lm_termsize.c c_lm_terminfo.c: ..$(slash)src$(slash)clib$(slash)lm_terminfo.c $(LN) ..$(slash)src$(slash)clib$(slash)lm_terminfo.c c_lm_terminfo.c c_lm_fs_case_sensitive.c: ..$(slash)src$(slash)clib$(slash)lm_fs_case_sensitive.c $(LN) ..$(slash)src$(slash)clib$(slash)lm_fs_case_sensitive.c c_lm_fs_case_sensitive.c lm_compat_win32.h: ..$(slash)src$(slash)clib$(slash)lm_compat_win32.h $(LN) ..$(slash)src$(slash)clib$(slash)lm_compat_win32.h lm_compat_win32.h SRC_clib = ..$(slash)src$(slash)clib ALLFILES_clib = c_lm_channel.c c_lm_printf.c c_lm_ctype.c c_lm_uname_ext.c c_lm_unix_cutil.c c_lm_compat_win32.c c_readline.c c_omake_shell_sys.c c_omake_shell_spawn.c c_fam_win32.c c_fam_kqueue.c c_fam_inotify.c c_lm_notify.c c_lm_termsize.c c_lm_terminfo.c c_lm_fs_case_sensitive.c lm_compat_win32.h CMOFILES_lm = lm_printf.cmo lm_debug.cmo lm_heap.cmo lm_list_util.cmo lm_array_util.cmo lm_set_sig.cmo lm_set.cmo lm_map_sig.cmo lm_map.cmo lm_int_set.cmo lm_termsize.cmo lm_terminfo.cmo lm_arg.cmo lm_index.cmo lm_thread_sig.cmo lm_thread_core.cmo lm_thread.cmo lm_string_util.cmo lm_string_set.cmo lm_hash.cmo lm_hash_code.cmo lm_symbol.cmo lm_location.cmo lm_position.cmo lm_filename_util.cmo lm_uname.cmo lm_thread_pool.cmo lm_channel.cmo lm_unix_util.cmo lm_db.cmo lm_notify.cmo lm_fs_case_sensitive.cmo lm_wild.cmo lm_readline.cmo lm_marshal.cmo lm_handle_table.cmo lm_int_handle_table.cmo lm_bitset.cmo lm_instrument.cmo CMXFILES_lm = lm_printf.cmx lm_debug.cmx lm_heap.cmx lm_list_util.cmx lm_array_util.cmx lm_set_sig.cmx lm_set.cmx lm_map_sig.cmx lm_map.cmx lm_int_set.cmx lm_termsize.cmx lm_terminfo.cmx lm_arg.cmx lm_index.cmx lm_thread_sig.cmx lm_thread_core.cmx lm_thread.cmx lm_string_util.cmx lm_string_set.cmx lm_hash.cmx lm_hash_code.cmx lm_symbol.cmx lm_location.cmx lm_position.cmx lm_filename_util.cmx lm_uname.cmx lm_thread_pool.cmx lm_channel.cmx lm_unix_util.cmx lm_db.cmx lm_notify.cmx lm_fs_case_sensitive.cmx lm_wild.cmx lm_readline.cmx lm_marshal.cmx lm_handle_table.cmx lm_int_handle_table.cmx lm_bitset.cmx lm_instrument.cmx OCAML_LIB_FLAGS_lm = lm.cma: $(CMOFILES_lm) $(OCAMLC) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_lm) -a -o $@ $(CMOFILES_lm) lm.cmxa: $(CMXFILES_lm) $(OCAMLOPT) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_lm) -a -o $@ $(CMXFILES_lm) lm_thread_pool.ml: ..$(slash)src$(slash)libmojave$(slash)lm_thread_pool_$(system).ml $(LN) ..$(slash)src$(slash)libmojave$(slash)lm_thread_pool_$(system).ml lm_thread_pool.ml lm_thread_core.ml: ..$(slash)src$(slash)libmojave$(slash)lm_thread_core_$(system).ml $(LN) ..$(slash)src$(slash)libmojave$(slash)lm_thread_core_$(system).ml lm_thread_core.ml SRC_libmojave = ..$(slash)src$(slash)libmojave lm_arg.ml: $(SRC_libmojave)$(slash)lm_arg.ml $(LN) $(SRC_libmojave)$(slash)lm_arg.ml lm_arg.ml lm_arg.mli: $(SRC_libmojave)$(slash)lm_arg.mli $(LN) $(SRC_libmojave)$(slash)lm_arg.mli lm_arg.mli lm_array_util.ml: $(SRC_libmojave)$(slash)lm_array_util.ml $(LN) $(SRC_libmojave)$(slash)lm_array_util.ml lm_array_util.ml lm_array_util.mli: $(SRC_libmojave)$(slash)lm_array_util.mli $(LN) $(SRC_libmojave)$(slash)lm_array_util.mli lm_array_util.mli lm_bitset.ml: $(SRC_libmojave)$(slash)lm_bitset.ml $(LN) $(SRC_libmojave)$(slash)lm_bitset.ml lm_bitset.ml lm_bitset.mli: $(SRC_libmojave)$(slash)lm_bitset.mli $(LN) $(SRC_libmojave)$(slash)lm_bitset.mli lm_bitset.mli lm_channel.ml: $(SRC_libmojave)$(slash)lm_channel.ml $(LN) $(SRC_libmojave)$(slash)lm_channel.ml lm_channel.ml lm_channel.mli: $(SRC_libmojave)$(slash)lm_channel.mli $(LN) $(SRC_libmojave)$(slash)lm_channel.mli lm_channel.mli lm_db.ml: $(SRC_libmojave)$(slash)lm_db.ml $(LN) $(SRC_libmojave)$(slash)lm_db.ml lm_db.ml lm_db.mli: $(SRC_libmojave)$(slash)lm_db.mli $(LN) $(SRC_libmojave)$(slash)lm_db.mli lm_db.mli lm_debug.ml: $(SRC_libmojave)$(slash)lm_debug.ml $(LN) $(SRC_libmojave)$(slash)lm_debug.ml lm_debug.ml lm_debug.mli: $(SRC_libmojave)$(slash)lm_debug.mli $(LN) $(SRC_libmojave)$(slash)lm_debug.mli lm_debug.mli lm_filename_util.ml: $(SRC_libmojave)$(slash)lm_filename_util.ml $(LN) $(SRC_libmojave)$(slash)lm_filename_util.ml lm_filename_util.ml lm_filename_util.mli: $(SRC_libmojave)$(slash)lm_filename_util.mli $(LN) $(SRC_libmojave)$(slash)lm_filename_util.mli lm_filename_util.mli lm_fs_case_sensitive.ml: $(SRC_libmojave)$(slash)lm_fs_case_sensitive.ml $(LN) $(SRC_libmojave)$(slash)lm_fs_case_sensitive.ml lm_fs_case_sensitive.ml lm_fs_case_sensitive.mli: $(SRC_libmojave)$(slash)lm_fs_case_sensitive.mli $(LN) $(SRC_libmojave)$(slash)lm_fs_case_sensitive.mli lm_fs_case_sensitive.mli lm_handle_table.ml: $(SRC_libmojave)$(slash)lm_handle_table.ml $(LN) $(SRC_libmojave)$(slash)lm_handle_table.ml lm_handle_table.ml lm_handle_table.mli: $(SRC_libmojave)$(slash)lm_handle_table.mli $(LN) $(SRC_libmojave)$(slash)lm_handle_table.mli lm_handle_table.mli lm_hash.ml: $(SRC_libmojave)$(slash)lm_hash.ml $(LN) $(SRC_libmojave)$(slash)lm_hash.ml lm_hash.ml lm_hash.mli: $(SRC_libmojave)$(slash)lm_hash.mli $(LN) $(SRC_libmojave)$(slash)lm_hash.mli lm_hash.mli lm_hash_code.ml: $(SRC_libmojave)$(slash)lm_hash_code.ml $(LN) $(SRC_libmojave)$(slash)lm_hash_code.ml lm_hash_code.ml lm_hash_code.mli: $(SRC_libmojave)$(slash)lm_hash_code.mli $(LN) $(SRC_libmojave)$(slash)lm_hash_code.mli lm_hash_code.mli lm_heap.ml: $(SRC_libmojave)$(slash)lm_heap.ml $(LN) $(SRC_libmojave)$(slash)lm_heap.ml lm_heap.ml lm_heap.mli: $(SRC_libmojave)$(slash)lm_heap.mli $(LN) $(SRC_libmojave)$(slash)lm_heap.mli lm_heap.mli lm_index.ml: $(SRC_libmojave)$(slash)lm_index.ml $(LN) $(SRC_libmojave)$(slash)lm_index.ml lm_index.ml lm_index.mli: $(SRC_libmojave)$(slash)lm_index.mli $(LN) $(SRC_libmojave)$(slash)lm_index.mli lm_index.mli lm_instrument.ml: $(SRC_libmojave)$(slash)lm_instrument.ml $(LN) $(SRC_libmojave)$(slash)lm_instrument.ml lm_instrument.ml lm_instrument.mli: $(SRC_libmojave)$(slash)lm_instrument.mli $(LN) $(SRC_libmojave)$(slash)lm_instrument.mli lm_instrument.mli lm_int_handle_table.ml: $(SRC_libmojave)$(slash)lm_int_handle_table.ml $(LN) $(SRC_libmojave)$(slash)lm_int_handle_table.ml lm_int_handle_table.ml lm_int_handle_table.mli: $(SRC_libmojave)$(slash)lm_int_handle_table.mli $(LN) $(SRC_libmojave)$(slash)lm_int_handle_table.mli lm_int_handle_table.mli lm_int_set.ml: $(SRC_libmojave)$(slash)lm_int_set.ml $(LN) $(SRC_libmojave)$(slash)lm_int_set.ml lm_int_set.ml lm_int_set.mli: $(SRC_libmojave)$(slash)lm_int_set.mli $(LN) $(SRC_libmojave)$(slash)lm_int_set.mli lm_int_set.mli lm_list_util.ml: $(SRC_libmojave)$(slash)lm_list_util.ml $(LN) $(SRC_libmojave)$(slash)lm_list_util.ml lm_list_util.ml lm_list_util.mli: $(SRC_libmojave)$(slash)lm_list_util.mli $(LN) $(SRC_libmojave)$(slash)lm_list_util.mli lm_list_util.mli lm_location.ml: $(SRC_libmojave)$(slash)lm_location.ml $(LN) $(SRC_libmojave)$(slash)lm_location.ml lm_location.ml lm_location.mli: $(SRC_libmojave)$(slash)lm_location.mli $(LN) $(SRC_libmojave)$(slash)lm_location.mli lm_location.mli lm_map.ml: $(SRC_libmojave)$(slash)lm_map.ml $(LN) $(SRC_libmojave)$(slash)lm_map.ml lm_map.ml lm_map.mli: $(SRC_libmojave)$(slash)lm_map.mli $(LN) $(SRC_libmojave)$(slash)lm_map.mli lm_map.mli lm_map_sig.ml: $(SRC_libmojave)$(slash)lm_map_sig.ml $(LN) $(SRC_libmojave)$(slash)lm_map_sig.ml lm_map_sig.ml lm_marshal.ml: $(SRC_libmojave)$(slash)lm_marshal.ml $(LN) $(SRC_libmojave)$(slash)lm_marshal.ml lm_marshal.ml lm_marshal.mli: $(SRC_libmojave)$(slash)lm_marshal.mli $(LN) $(SRC_libmojave)$(slash)lm_marshal.mli lm_marshal.mli lm_notify.ml: $(SRC_libmojave)$(slash)lm_notify.ml $(LN) $(SRC_libmojave)$(slash)lm_notify.ml lm_notify.ml lm_notify.mli: $(SRC_libmojave)$(slash)lm_notify.mli $(LN) $(SRC_libmojave)$(slash)lm_notify.mli lm_notify.mli lm_position.ml: $(SRC_libmojave)$(slash)lm_position.ml $(LN) $(SRC_libmojave)$(slash)lm_position.ml lm_position.ml lm_position.mli: $(SRC_libmojave)$(slash)lm_position.mli $(LN) $(SRC_libmojave)$(slash)lm_position.mli lm_position.mli lm_printf.ml: $(SRC_libmojave)$(slash)lm_printf.ml $(LN) $(SRC_libmojave)$(slash)lm_printf.ml lm_printf.ml lm_printf.mli: $(SRC_libmojave)$(slash)lm_printf.mli $(LN) $(SRC_libmojave)$(slash)lm_printf.mli lm_printf.mli lm_readline.ml: $(SRC_libmojave)$(slash)lm_readline.ml $(LN) $(SRC_libmojave)$(slash)lm_readline.ml lm_readline.ml lm_readline.mli: $(SRC_libmojave)$(slash)lm_readline.mli $(LN) $(SRC_libmojave)$(slash)lm_readline.mli lm_readline.mli lm_set.ml: $(SRC_libmojave)$(slash)lm_set.ml $(LN) $(SRC_libmojave)$(slash)lm_set.ml lm_set.ml lm_set.mli: $(SRC_libmojave)$(slash)lm_set.mli $(LN) $(SRC_libmojave)$(slash)lm_set.mli lm_set.mli lm_set_sig.ml: $(SRC_libmojave)$(slash)lm_set_sig.ml $(LN) $(SRC_libmojave)$(slash)lm_set_sig.ml lm_set_sig.ml lm_string_set.ml: $(SRC_libmojave)$(slash)lm_string_set.ml $(LN) $(SRC_libmojave)$(slash)lm_string_set.ml lm_string_set.ml lm_string_set.mli: $(SRC_libmojave)$(slash)lm_string_set.mli $(LN) $(SRC_libmojave)$(slash)lm_string_set.mli lm_string_set.mli lm_string_util.ml: $(SRC_libmojave)$(slash)lm_string_util.ml $(LN) $(SRC_libmojave)$(slash)lm_string_util.ml lm_string_util.ml lm_string_util.mli: $(SRC_libmojave)$(slash)lm_string_util.mli $(LN) $(SRC_libmojave)$(slash)lm_string_util.mli lm_string_util.mli lm_symbol.ml: $(SRC_libmojave)$(slash)lm_symbol.ml $(LN) $(SRC_libmojave)$(slash)lm_symbol.ml lm_symbol.ml lm_symbol.mli: $(SRC_libmojave)$(slash)lm_symbol.mli $(LN) $(SRC_libmojave)$(slash)lm_symbol.mli lm_symbol.mli lm_terminfo.ml: $(SRC_libmojave)$(slash)lm_terminfo.ml $(LN) $(SRC_libmojave)$(slash)lm_terminfo.ml lm_terminfo.ml lm_terminfo.mli: $(SRC_libmojave)$(slash)lm_terminfo.mli $(LN) $(SRC_libmojave)$(slash)lm_terminfo.mli lm_terminfo.mli lm_termsize.ml: $(SRC_libmojave)$(slash)lm_termsize.ml $(LN) $(SRC_libmojave)$(slash)lm_termsize.ml lm_termsize.ml lm_termsize.mli: $(SRC_libmojave)$(slash)lm_termsize.mli $(LN) $(SRC_libmojave)$(slash)lm_termsize.mli lm_termsize.mli lm_thread.ml: $(SRC_libmojave)$(slash)lm_thread.ml $(LN) $(SRC_libmojave)$(slash)lm_thread.ml lm_thread.ml lm_thread.mli: $(SRC_libmojave)$(slash)lm_thread.mli $(LN) $(SRC_libmojave)$(slash)lm_thread.mli lm_thread.mli lm_thread_core.mli: $(SRC_libmojave)$(slash)lm_thread_core.mli $(LN) $(SRC_libmojave)$(slash)lm_thread_core.mli lm_thread_core.mli lm_thread_pool.mli: $(SRC_libmojave)$(slash)lm_thread_pool.mli $(LN) $(SRC_libmojave)$(slash)lm_thread_pool.mli lm_thread_pool.mli lm_thread_sig.ml: $(SRC_libmojave)$(slash)lm_thread_sig.ml $(LN) $(SRC_libmojave)$(slash)lm_thread_sig.ml lm_thread_sig.ml lm_uname.ml: $(SRC_libmojave)$(slash)lm_uname.ml $(LN) $(SRC_libmojave)$(slash)lm_uname.ml lm_uname.ml lm_uname.mli: $(SRC_libmojave)$(slash)lm_uname.mli $(LN) $(SRC_libmojave)$(slash)lm_uname.mli lm_uname.mli lm_unix_util.ml: $(SRC_libmojave)$(slash)lm_unix_util.ml $(LN) $(SRC_libmojave)$(slash)lm_unix_util.ml lm_unix_util.ml lm_unix_util.mli: $(SRC_libmojave)$(slash)lm_unix_util.mli $(LN) $(SRC_libmojave)$(slash)lm_unix_util.mli lm_unix_util.mli lm_wild.ml: $(SRC_libmojave)$(slash)lm_wild.ml $(LN) $(SRC_libmojave)$(slash)lm_wild.ml lm_wild.ml lm_wild.mli: $(SRC_libmojave)$(slash)lm_wild.mli $(LN) $(SRC_libmojave)$(slash)lm_wild.mli lm_wild.mli ALLFILES_libmojave = lm_arg.ml lm_arg.mli lm_array_util.ml lm_array_util.mli lm_bitset.ml lm_bitset.mli lm_channel.ml lm_channel.mli lm_db.ml lm_db.mli lm_debug.ml lm_debug.mli lm_filename_util.ml lm_filename_util.mli lm_fs_case_sensitive.ml lm_fs_case_sensitive.mli lm_handle_table.ml lm_handle_table.mli lm_hash.ml lm_hash.mli lm_hash_code.ml lm_hash_code.mli lm_heap.ml lm_heap.mli lm_index.ml lm_index.mli lm_instrument.ml lm_instrument.mli lm_int_handle_table.ml lm_int_handle_table.mli lm_int_set.ml lm_int_set.mli lm_list_util.ml lm_list_util.mli lm_location.ml lm_location.mli lm_map.ml lm_map.mli lm_map_sig.ml lm_marshal.ml lm_marshal.mli lm_notify.ml lm_notify.mli lm_position.ml lm_position.mli lm_printf.ml lm_printf.mli lm_readline.ml lm_readline.mli lm_set.ml lm_set.mli lm_set_sig.ml lm_string_set.ml lm_string_set.mli lm_string_util.ml lm_string_util.mli lm_symbol.ml lm_symbol.mli lm_terminfo.ml lm_terminfo.mli lm_termsize.ml lm_termsize.mli lm_thread.ml lm_thread.mli lm_thread_core.mli lm_thread_pool.mli lm_thread_sig.ml lm_uname.ml lm_uname.mli lm_unix_util.ml lm_unix_util.mli lm_wild.ml lm_wild.mli lm_thread_pool.ml lm_thread_core.ml CMOFILES_frt = lm_hash_cons.cmo lm_lexer.cmo lm_parser.cmo lm_glob.cmo CMXFILES_frt = lm_hash_cons.cmx lm_lexer.cmx lm_parser.cmx lm_glob.cmx OCAML_LIB_FLAGS_frt = frt.cma: $(CMOFILES_frt) $(OCAMLC) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_frt) -a -o $@ $(CMOFILES_frt) frt.cmxa: $(CMXFILES_frt) $(OCAMLOPT) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_frt) -a -o $@ $(CMXFILES_frt) SRC_front = ..$(slash)src$(slash)front lm_glob.ml: $(SRC_front)$(slash)lm_glob.ml $(LN) $(SRC_front)$(slash)lm_glob.ml lm_glob.ml lm_glob.mli: $(SRC_front)$(slash)lm_glob.mli $(LN) $(SRC_front)$(slash)lm_glob.mli lm_glob.mli lm_hash_cons.ml: $(SRC_front)$(slash)lm_hash_cons.ml $(LN) $(SRC_front)$(slash)lm_hash_cons.ml lm_hash_cons.ml lm_hash_cons.mli: $(SRC_front)$(slash)lm_hash_cons.mli $(LN) $(SRC_front)$(slash)lm_hash_cons.mli lm_hash_cons.mli lm_lexer.ml: $(SRC_front)$(slash)lm_lexer.ml $(LN) $(SRC_front)$(slash)lm_lexer.ml lm_lexer.ml lm_lexer.mli: $(SRC_front)$(slash)lm_lexer.mli $(LN) $(SRC_front)$(slash)lm_lexer.mli lm_lexer.mli lm_parser.ml: $(SRC_front)$(slash)lm_parser.ml $(LN) $(SRC_front)$(slash)lm_parser.ml lm_parser.ml lm_parser.mli: $(SRC_front)$(slash)lm_parser.mli $(LN) $(SRC_front)$(slash)lm_parser.mli lm_parser.mli ALLFILES_front = lm_glob.ml lm_glob.mli lm_hash_cons.ml lm_hash_cons.mli lm_lexer.ml lm_lexer.mli lm_parser.ml lm_parser.mli CMOFILES_omake_gen_magic = omake_gen_magic.cmo CMXFILES_omake_gen_magic = omake_gen_magic.cmx OCAML_LIBS_omake_gen_magic = lm.cma frt.cma OCAML_LIBS_OPT_omake_gen_magic = lm.cmxa frt.cmxa OCAML_OTHER_LIBS_omake_gen_magic = unix.cma OCAML_OTHER_LIBS_OPT_omake_gen_magic = unix.cmxa OCAML_CLIBS_omake_gen_magic = clib$(EXT_LIB) OCAML_CCLIBS_omake_gen_magic = -cclib clib$(EXT_LIB) omake_gen_magic.byte$(EXE): $(CMOFILES_omake_gen_magic) $(OCAML_LIBS_omake_gen_magic) $(OCAML_CLIBS_omake_gen_magic) $(OCAMLC) $(OCAMLFLAGS) -custom -o $@ $(OCAML_CCLIBS_omake_gen_magic) $(OCAML_OTHER_LIBS_omake_gen_magic) $(THREADSLIB) $(OCAML_LIBS_omake_gen_magic) $(CMOFILES_omake_gen_magic) omake_gen_magic.opt$(EXE): $(CMXFILES_omake_gen_magic) $(OCAML_LIBS_OPT_omake_gen_magic) $(OCAML_CLIBS_omake_gen_magic) $(OCAMLOPT) $(OCAMLFLAGS) -o $@ $(OCAML_CCLIBS_omake_gen_magic) $(OCAML_OTHER_LIBS_OPT_omake_gen_magic) $(THREADSLIB_OPT) $(OCAML_LIBS_OPT_omake_gen_magic) $(CMXFILES_omake_gen_magic) omake_gen_magic$(EXE): omake_gen_magic$(PREFERRED)$(EXE) $(LN) omake_gen_magic$(PREFERRED)$(EXE) $@ CMOFILES_magic = omake_magic.cmo CMXFILES_magic = omake_magic.cmx OCAML_LIB_FLAGS_magic = magic.cma: $(CMOFILES_magic) $(OCAMLC) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_magic) -a -o $@ $(CMOFILES_magic) magic.cmxa: $(CMXFILES_magic) $(OCAMLOPT) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_magic) -a -o $@ $(CMXFILES_magic) GENMAGIC_DEPS = lm_filename_util.ml lm_hash.ml lm_location.ml lm_map.ml lm_position.ml lm_set.ml lm_symbol.ml omake_value_type.ml omake_cache.ml omake_cache_type.ml omake_node.ml omake_command_digest.ml lm_filename_util.ml lm_hash.ml lm_location.ml lm_symbol.ml lm_map.ml lm_set.ml omake_node.ml omake_ir.ml lm_filename_util.ml lm_hash.ml lm_lexer.ml lm_location.ml lm_map.ml lm_parser.ml lm_position.ml lm_set.ml lm_symbol.ml omake_value_type.ml omake_cache_type.ml omake_ir.ml omake_node.ml omake_env.ml version.txt MAGIC_FILES = --cache-files lm_filename_util.ml lm_hash.ml lm_location.ml lm_map.ml lm_position.ml lm_set.ml lm_symbol.ml omake_value_type.ml omake_cache.ml omake_cache_type.ml omake_node.ml omake_command_digest.ml --omc-files lm_filename_util.ml lm_hash.ml lm_location.ml lm_symbol.ml lm_map.ml lm_set.ml omake_node.ml omake_ir.ml --omo-files lm_filename_util.ml lm_hash.ml lm_lexer.ml lm_location.ml lm_map.ml lm_parser.ml lm_position.ml lm_set.ml lm_symbol.ml omake_value_type.ml omake_cache_type.ml omake_ir.ml omake_node.ml omake_env.ml omake_magic.ml: omake_gen_magic$(EXE) $(GENMAGIC_DEPS) $(DOT)omake_gen_magic -o $@ --version version.txt --var "omake_cc=$(CC)" --var "omake_cflags=$(CFLAGS)" --var "omake_ccomptype=$(CCOMPTYPE)" --magic $(MAGIC_FILES) SRC_magic = ..$(slash)src$(slash)magic omake_gen_magic.ml: $(SRC_magic)$(slash)omake_gen_magic.ml $(LN) $(SRC_magic)$(slash)omake_gen_magic.ml omake_gen_magic.ml ALLFILES_magic = omake_gen_magic.ml CMOFILES_ir = omake_options.cmo omake_symbol.cmo omake_state.cmo omake_node_type.cmo omake_node_sig.cmo omake_node.cmo omake_install.cmo omake_ir.cmo omake_var.cmo omake_ir_util.cmo omake_ir_print.cmo omake_ir_free_vars.cmo omake_lexer.cmo omake_parser.cmo omake_value_type.cmo omake_command_type.cmo omake_value_util.cmo omake_value_print.cmo omake_pos.cmo omake_shell_type.cmo omake_command.cmo omake_cache_type.cmo omake_cache.cmo CMXFILES_ir = omake_options.cmx omake_symbol.cmx omake_state.cmx omake_node_type.cmx omake_node_sig.cmx omake_node.cmx omake_install.cmx omake_ir.cmx omake_var.cmx omake_ir_util.cmx omake_ir_print.cmx omake_ir_free_vars.cmx omake_lexer.cmx omake_parser.cmx omake_value_type.cmx omake_command_type.cmx omake_value_util.cmx omake_value_print.cmx omake_pos.cmx omake_shell_type.cmx omake_command.cmx omake_cache_type.cmx omake_cache.cmx OCAML_LIB_FLAGS_ir = ir.cma: $(CMOFILES_ir) $(OCAMLC) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_ir) -a -o $@ $(CMOFILES_ir) ir.cmxa: $(CMXFILES_ir) $(OCAMLOPT) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_ir) -a -o $@ $(CMXFILES_ir) omake_options.cmx omake_symbol.cmx omake_state.cmx omake_node_type.cmx omake_node_sig.cmx omake_node.cmx omake_install.cmx omake_ir.cmx omake_var.cmx omake_ir_util.cmx omake_ir_print.cmx omake_ir_free_vars.cmx omake_lexer.cmx omake_parser.cmx omake_value_type.cmx omake_command_type.cmx omake_value_util.cmx omake_value_print.cmx omake_pos.cmx omake_shell_type.cmx omake_command.cmx omake_cache_type.cmx omake_cache.cmx omake_options.cmo omake_symbol.cmo omake_state.cmo omake_node_type.cmo omake_node_sig.cmo omake_node.cmo omake_install.cmo omake_ir.cmo omake_var.cmo omake_ir_util.cmo omake_ir_print.cmo omake_ir_free_vars.cmo omake_lexer.cmo omake_parser.cmo omake_value_type.cmo omake_command_type.cmo omake_value_util.cmo omake_value_print.cmo omake_pos.cmo omake_shell_type.cmo omake_command.cmo omake_cache_type.cmo omake_cache.cmo omake_options.cmi omake_state.cmi omake_node.cmi omake_install.cmi omake_var.cmi omake_ir_print.cmi omake_ir_free_vars.cmi omake_command_type.cmi omake_value_util.cmi omake_value_print.cmi omake_pos.cmi omake_command.cmi omake_cache.cmi: magic.cma SRC_ir = ..$(slash)src$(slash)ir omake_cache.ml: $(SRC_ir)$(slash)omake_cache.ml $(LN) $(SRC_ir)$(slash)omake_cache.ml omake_cache.ml omake_cache.mli: $(SRC_ir)$(slash)omake_cache.mli $(LN) $(SRC_ir)$(slash)omake_cache.mli omake_cache.mli omake_cache_type.ml: $(SRC_ir)$(slash)omake_cache_type.ml $(LN) $(SRC_ir)$(slash)omake_cache_type.ml omake_cache_type.ml omake_command.ml: $(SRC_ir)$(slash)omake_command.ml $(LN) $(SRC_ir)$(slash)omake_command.ml omake_command.ml omake_command.mli: $(SRC_ir)$(slash)omake_command.mli $(LN) $(SRC_ir)$(slash)omake_command.mli omake_command.mli omake_command_type.ml: $(SRC_ir)$(slash)omake_command_type.ml $(LN) $(SRC_ir)$(slash)omake_command_type.ml omake_command_type.ml omake_command_type.mli: $(SRC_ir)$(slash)omake_command_type.mli $(LN) $(SRC_ir)$(slash)omake_command_type.mli omake_command_type.mli omake_install.ml: $(SRC_ir)$(slash)omake_install.ml $(LN) $(SRC_ir)$(slash)omake_install.ml omake_install.ml omake_install.mli: $(SRC_ir)$(slash)omake_install.mli $(LN) $(SRC_ir)$(slash)omake_install.mli omake_install.mli omake_ir.ml: $(SRC_ir)$(slash)omake_ir.ml $(LN) $(SRC_ir)$(slash)omake_ir.ml omake_ir.ml omake_ir_free_vars.ml: $(SRC_ir)$(slash)omake_ir_free_vars.ml $(LN) $(SRC_ir)$(slash)omake_ir_free_vars.ml omake_ir_free_vars.ml omake_ir_free_vars.mli: $(SRC_ir)$(slash)omake_ir_free_vars.mli $(LN) $(SRC_ir)$(slash)omake_ir_free_vars.mli omake_ir_free_vars.mli omake_ir_print.ml: $(SRC_ir)$(slash)omake_ir_print.ml $(LN) $(SRC_ir)$(slash)omake_ir_print.ml omake_ir_print.ml omake_ir_print.mli: $(SRC_ir)$(slash)omake_ir_print.mli $(LN) $(SRC_ir)$(slash)omake_ir_print.mli omake_ir_print.mli omake_ir_util.ml: $(SRC_ir)$(slash)omake_ir_util.ml $(LN) $(SRC_ir)$(slash)omake_ir_util.ml omake_ir_util.ml omake_lexer.ml: $(SRC_ir)$(slash)omake_lexer.ml $(LN) $(SRC_ir)$(slash)omake_lexer.ml omake_lexer.ml omake_node.ml: $(SRC_ir)$(slash)omake_node.ml $(LN) $(SRC_ir)$(slash)omake_node.ml omake_node.ml omake_node.mli: $(SRC_ir)$(slash)omake_node.mli $(LN) $(SRC_ir)$(slash)omake_node.mli omake_node.mli omake_node_sig.ml: $(SRC_ir)$(slash)omake_node_sig.ml $(LN) $(SRC_ir)$(slash)omake_node_sig.ml omake_node_sig.ml omake_node_type.ml: $(SRC_ir)$(slash)omake_node_type.ml $(LN) $(SRC_ir)$(slash)omake_node_type.ml omake_node_type.ml omake_options.ml: $(SRC_ir)$(slash)omake_options.ml $(LN) $(SRC_ir)$(slash)omake_options.ml omake_options.ml omake_options.mli: $(SRC_ir)$(slash)omake_options.mli $(LN) $(SRC_ir)$(slash)omake_options.mli omake_options.mli omake_parser.ml: $(SRC_ir)$(slash)omake_parser.ml $(LN) $(SRC_ir)$(slash)omake_parser.ml omake_parser.ml omake_pos.ml: $(SRC_ir)$(slash)omake_pos.ml $(LN) $(SRC_ir)$(slash)omake_pos.ml omake_pos.ml omake_pos.mli: $(SRC_ir)$(slash)omake_pos.mli $(LN) $(SRC_ir)$(slash)omake_pos.mli omake_pos.mli omake_shell_type.ml: $(SRC_ir)$(slash)omake_shell_type.ml $(LN) $(SRC_ir)$(slash)omake_shell_type.ml omake_shell_type.ml omake_state.ml: $(SRC_ir)$(slash)omake_state.ml $(LN) $(SRC_ir)$(slash)omake_state.ml omake_state.ml omake_state.mli: $(SRC_ir)$(slash)omake_state.mli $(LN) $(SRC_ir)$(slash)omake_state.mli omake_state.mli omake_symbol.ml: $(SRC_ir)$(slash)omake_symbol.ml $(LN) $(SRC_ir)$(slash)omake_symbol.ml omake_symbol.ml omake_value_print.ml: $(SRC_ir)$(slash)omake_value_print.ml $(LN) $(SRC_ir)$(slash)omake_value_print.ml omake_value_print.ml omake_value_print.mli: $(SRC_ir)$(slash)omake_value_print.mli $(LN) $(SRC_ir)$(slash)omake_value_print.mli omake_value_print.mli omake_value_type.ml: $(SRC_ir)$(slash)omake_value_type.ml $(LN) $(SRC_ir)$(slash)omake_value_type.ml omake_value_type.ml omake_value_util.ml: $(SRC_ir)$(slash)omake_value_util.ml $(LN) $(SRC_ir)$(slash)omake_value_util.ml omake_value_util.ml omake_value_util.mli: $(SRC_ir)$(slash)omake_value_util.mli $(LN) $(SRC_ir)$(slash)omake_value_util.mli omake_value_util.mli omake_var.ml: $(SRC_ir)$(slash)omake_var.ml $(LN) $(SRC_ir)$(slash)omake_var.ml omake_var.ml omake_var.mli: $(SRC_ir)$(slash)omake_var.mli $(LN) $(SRC_ir)$(slash)omake_var.mli omake_var.mli ALLFILES_ir = omake_cache.ml omake_cache.mli omake_cache_type.ml omake_command.ml omake_command.mli omake_command_type.ml omake_command_type.mli omake_install.ml omake_install.mli omake_ir.ml omake_ir_free_vars.ml omake_ir_free_vars.mli omake_ir_print.ml omake_ir_print.mli omake_ir_util.ml omake_lexer.ml omake_node.ml omake_node.mli omake_node_sig.ml omake_node_type.ml omake_options.ml omake_options.mli omake_parser.ml omake_pos.ml omake_pos.mli omake_shell_type.ml omake_state.ml omake_state.mli omake_symbol.ml omake_value_print.ml omake_value_print.mli omake_value_type.ml omake_value_util.ml omake_value_util.mli omake_var.ml omake_var.mli CMOFILES_exec = omake_exec_id.cmo omake_exec_type.cmo omake_exec_print.cmo omake_exec_util.cmo omake_exec_local.cmo omake_exec_remote.cmo omake_exec_notify.cmo omake_exec.cmo CMXFILES_exec = omake_exec_id.cmx omake_exec_type.cmx omake_exec_print.cmx omake_exec_util.cmx omake_exec_local.cmx omake_exec_remote.cmx omake_exec_notify.cmx omake_exec.cmx OCAML_LIB_FLAGS_exec = exec.cma: $(CMOFILES_exec) $(OCAMLC) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_exec) -a -o $@ $(CMOFILES_exec) exec.cmxa: $(CMXFILES_exec) $(OCAMLOPT) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_exec) -a -o $@ $(CMXFILES_exec) SRC_exec = ..$(slash)src$(slash)exec omake_exec.ml: $(SRC_exec)$(slash)omake_exec.ml $(LN) $(SRC_exec)$(slash)omake_exec.ml omake_exec.ml omake_exec.mli: $(SRC_exec)$(slash)omake_exec.mli $(LN) $(SRC_exec)$(slash)omake_exec.mli omake_exec.mli omake_exec_id.ml: $(SRC_exec)$(slash)omake_exec_id.ml $(LN) $(SRC_exec)$(slash)omake_exec_id.ml omake_exec_id.ml omake_exec_id.mli: $(SRC_exec)$(slash)omake_exec_id.mli $(LN) $(SRC_exec)$(slash)omake_exec_id.mli omake_exec_id.mli omake_exec_local.ml: $(SRC_exec)$(slash)omake_exec_local.ml $(LN) $(SRC_exec)$(slash)omake_exec_local.ml omake_exec_local.ml omake_exec_local.mli: $(SRC_exec)$(slash)omake_exec_local.mli $(LN) $(SRC_exec)$(slash)omake_exec_local.mli omake_exec_local.mli omake_exec_notify.ml: $(SRC_exec)$(slash)omake_exec_notify.ml $(LN) $(SRC_exec)$(slash)omake_exec_notify.ml omake_exec_notify.ml omake_exec_notify.mli: $(SRC_exec)$(slash)omake_exec_notify.mli $(LN) $(SRC_exec)$(slash)omake_exec_notify.mli omake_exec_notify.mli omake_exec_print.ml: $(SRC_exec)$(slash)omake_exec_print.ml $(LN) $(SRC_exec)$(slash)omake_exec_print.ml omake_exec_print.ml omake_exec_print.mli: $(SRC_exec)$(slash)omake_exec_print.mli $(LN) $(SRC_exec)$(slash)omake_exec_print.mli omake_exec_print.mli omake_exec_remote.ml: $(SRC_exec)$(slash)omake_exec_remote.ml $(LN) $(SRC_exec)$(slash)omake_exec_remote.ml omake_exec_remote.ml omake_exec_remote.mli: $(SRC_exec)$(slash)omake_exec_remote.mli $(LN) $(SRC_exec)$(slash)omake_exec_remote.mli omake_exec_remote.mli omake_exec_type.ml: $(SRC_exec)$(slash)omake_exec_type.ml $(LN) $(SRC_exec)$(slash)omake_exec_type.ml omake_exec_type.ml omake_exec_util.ml: $(SRC_exec)$(slash)omake_exec_util.ml $(LN) $(SRC_exec)$(slash)omake_exec_util.ml omake_exec_util.ml omake_exec_util.mli: $(SRC_exec)$(slash)omake_exec_util.mli $(LN) $(SRC_exec)$(slash)omake_exec_util.mli omake_exec_util.mli ALLFILES_exec = omake_exec.ml omake_exec.mli omake_exec_id.ml omake_exec_id.mli omake_exec_local.ml omake_exec_local.mli omake_exec_notify.ml omake_exec_notify.mli omake_exec_print.ml omake_exec_print.mli omake_exec_remote.ml omake_exec_remote.mli omake_exec_type.ml omake_exec_util.ml omake_exec_util.mli CMOFILES_ast = omake_ast.cmo omake_ast_util.cmo omake_ast_print.cmo CMXFILES_ast = omake_ast.cmx omake_ast_util.cmx omake_ast_print.cmx OCAML_LIB_FLAGS_ast = ast.cma: $(CMOFILES_ast) $(OCAMLC) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_ast) -a -o $@ $(CMOFILES_ast) ast.cmxa: $(CMXFILES_ast) $(OCAMLOPT) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_ast) -a -o $@ $(CMXFILES_ast) SRC_ast = ..$(slash)src$(slash)ast omake_ast.ml: $(SRC_ast)$(slash)omake_ast.ml $(LN) $(SRC_ast)$(slash)omake_ast.ml omake_ast.ml omake_ast_print.ml: $(SRC_ast)$(slash)omake_ast_print.ml $(LN) $(SRC_ast)$(slash)omake_ast_print.ml omake_ast_print.ml omake_ast_print.mli: $(SRC_ast)$(slash)omake_ast_print.mli $(LN) $(SRC_ast)$(slash)omake_ast_print.mli omake_ast_print.mli omake_ast_util.ml: $(SRC_ast)$(slash)omake_ast_util.ml $(LN) $(SRC_ast)$(slash)omake_ast_util.ml omake_ast_util.ml omake_ast_util.mli: $(SRC_ast)$(slash)omake_ast_util.mli $(LN) $(SRC_ast)$(slash)omake_ast_util.mli omake_ast_util.mli ALLFILES_ast = omake_ast.ml omake_ast_print.ml omake_ast_print.mli omake_ast_util.ml omake_ast_util.mli CMOFILES_omake_gen_parse = omake_gen_parse.cmo CMXFILES_omake_gen_parse = omake_gen_parse.cmx OCAML_LIBS_omake_gen_parse = OCAML_LIBS_OPT_omake_gen_parse = OCAML_OTHER_LIBS_omake_gen_parse = unix.cma OCAML_OTHER_LIBS_OPT_omake_gen_parse = unix.cmxa OCAML_CLIBS_omake_gen_parse = OCAML_CCLIBS_omake_gen_parse = omake_gen_parse.byte$(EXE): $(CMOFILES_omake_gen_parse) $(OCAML_LIBS_omake_gen_parse) $(OCAML_CLIBS_omake_gen_parse) $(OCAMLC) $(OCAMLFLAGS) -custom -o $@ $(OCAML_CCLIBS_omake_gen_parse) $(OCAML_OTHER_LIBS_omake_gen_parse) $(THREADSLIB) $(OCAML_LIBS_omake_gen_parse) $(CMOFILES_omake_gen_parse) omake_gen_parse.opt$(EXE): $(CMXFILES_omake_gen_parse) $(OCAML_LIBS_OPT_omake_gen_parse) $(OCAML_CLIBS_omake_gen_parse) $(OCAMLOPT) $(OCAMLFLAGS) -o $@ $(OCAML_CCLIBS_omake_gen_parse) $(OCAML_OTHER_LIBS_OPT_omake_gen_parse) $(THREADSLIB_OPT) $(OCAML_LIBS_OPT_omake_gen_parse) $(CMXFILES_omake_gen_parse) omake_gen_parse$(EXE): omake_gen_parse$(PREFERRED)$(EXE) $(LN) omake_gen_parse$(PREFERRED)$(EXE) $@ CMOFILES_env = omake_env.cmo omake_exn_print.cmo omake_ast_parse.cmo omake_ast_lex.cmo omake_exp_parse.cmo omake_exp_lex.cmo omake_ir_ast.cmo omake_ir_semant.cmo omake_command_digest.cmo CMXFILES_env = omake_env.cmx omake_exn_print.cmx omake_ast_parse.cmx omake_ast_lex.cmx omake_exp_parse.cmx omake_exp_lex.cmx omake_ir_ast.cmx omake_ir_semant.cmx omake_command_digest.cmx OCAML_LIB_FLAGS_env = env.cma: $(CMOFILES_env) $(OCAMLC) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_env) -a -o $@ $(CMOFILES_env) env.cmxa: $(CMXFILES_env) $(OCAMLOPT) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_env) -a -o $@ $(CMXFILES_env) GENPARSE = omake_gen_parse omake_ast_parse.mly: $(GENPARSE)$(EXE) omake_ast_parse.input $(DOT)$(GENPARSE) -o $@ omake_ast_parse.input omake_ast_lex.ml: omake_ast_lex.mll omake_ast_lex.cmo: omake_ast_lex.cmi omake_ast_parse.ml: omake_ast_parse.mly omake_ast_parse.mli: omake_ast_parse.mly omake_ast_parse.cmo: omake_ast_parse.cmi omake_exp_parse.ml: omake_exp_parse.mly omake_exp_parse.mli: omake_exp_parse.mly omake_exp_parse.cmo: omake_exp_parse.cmi omake_ast_lex.mll: ..$(slash)src$(slash)env$(slash)omake_ast_lex.mll $(LN) ..$(slash)src$(slash)env$(slash)omake_ast_lex.mll omake_ast_lex.mll omake_ast_parse.input: ..$(slash)src$(slash)env$(slash)omake_ast_parse.input $(LN) ..$(slash)src$(slash)env$(slash)omake_ast_parse.input omake_ast_parse.input omake_exp_parse.mly: ..$(slash)src$(slash)env$(slash)omake_exp_parse.mly $(LN) ..$(slash)src$(slash)env$(slash)omake_exp_parse.mly omake_exp_parse.mly omake_env.cmx omake_exn_print.cmx omake_ast_parse.cmx omake_ast_lex.cmx omake_exp_parse.cmx omake_exp_lex.cmx omake_ir_ast.cmx omake_ir_semant.cmx omake_command_digest.cmx omake_env.cmo omake_exn_print.cmo omake_ast_parse.cmo omake_ast_lex.cmo omake_exp_parse.cmo omake_exp_lex.cmo omake_ir_ast.cmo omake_ir_semant.cmo omake_command_digest.cmo omake_env.cmi omake_exn_print.cmi omake_ast_parse.cmi omake_ast_lex.cmi omake_exp_parse.cmi omake_exp_lex.cmi omake_ir_ast.cmi omake_ir_semant.cmi omake_command_digest.cmi: magic.cma Makefile.dep: omake_ast_lex.ml omake_ast_parse.mly omake_ast_parse.mli omake_ast_parse.ml omake_exp_parse.ml omake_exp_parse.mli SRC_env = ..$(slash)src$(slash)env omake_ast_lex.mli: $(SRC_env)$(slash)omake_ast_lex.mli $(LN) $(SRC_env)$(slash)omake_ast_lex.mli omake_ast_lex.mli omake_command_digest.ml: $(SRC_env)$(slash)omake_command_digest.ml $(LN) $(SRC_env)$(slash)omake_command_digest.ml omake_command_digest.ml omake_command_digest.mli: $(SRC_env)$(slash)omake_command_digest.mli $(LN) $(SRC_env)$(slash)omake_command_digest.mli omake_command_digest.mli omake_env.ml: $(SRC_env)$(slash)omake_env.ml $(LN) $(SRC_env)$(slash)omake_env.ml omake_env.ml omake_env.mli: $(SRC_env)$(slash)omake_env.mli $(LN) $(SRC_env)$(slash)omake_env.mli omake_env.mli omake_exn_print.ml: $(SRC_env)$(slash)omake_exn_print.ml $(LN) $(SRC_env)$(slash)omake_exn_print.ml omake_exn_print.ml omake_exn_print.mli: $(SRC_env)$(slash)omake_exn_print.mli $(LN) $(SRC_env)$(slash)omake_exn_print.mli omake_exn_print.mli omake_exp_lex.ml: $(SRC_env)$(slash)omake_exp_lex.ml $(LN) $(SRC_env)$(slash)omake_exp_lex.ml omake_exp_lex.ml omake_exp_lex.mli: $(SRC_env)$(slash)omake_exp_lex.mli $(LN) $(SRC_env)$(slash)omake_exp_lex.mli omake_exp_lex.mli omake_gen_parse.ml: $(SRC_env)$(slash)omake_gen_parse.ml $(LN) $(SRC_env)$(slash)omake_gen_parse.ml omake_gen_parse.ml omake_ir_ast.ml: $(SRC_env)$(slash)omake_ir_ast.ml $(LN) $(SRC_env)$(slash)omake_ir_ast.ml omake_ir_ast.ml omake_ir_ast.mli: $(SRC_env)$(slash)omake_ir_ast.mli $(LN) $(SRC_env)$(slash)omake_ir_ast.mli omake_ir_ast.mli omake_ir_semant.ml: $(SRC_env)$(slash)omake_ir_semant.ml $(LN) $(SRC_env)$(slash)omake_ir_semant.ml omake_ir_semant.ml omake_ir_semant.mli: $(SRC_env)$(slash)omake_ir_semant.mli $(LN) $(SRC_env)$(slash)omake_ir_semant.mli omake_ir_semant.mli ALLFILES_env = omake_ast_lex.mli omake_command_digest.ml omake_command_digest.mli omake_env.ml omake_env.mli omake_exn_print.ml omake_exn_print.mli omake_exp_lex.ml omake_exp_lex.mli omake_gen_parse.ml omake_ir_ast.ml omake_ir_ast.mli omake_ir_semant.ml omake_ir_semant.mli omake_ast_lex.mll omake_ast_parse.input omake_exp_parse.mly CMOFILES_shell = omake_shell_parse.cmo omake_shell_lex.cmo omake_shell_spawn.cmo omake_shell_sys_type.cmo omake_shell_sys.cmo omake_shell_job.cmo omake_shell_completion.cmo CMXFILES_shell = omake_shell_parse.cmx omake_shell_lex.cmx omake_shell_spawn.cmx omake_shell_sys_type.cmx omake_shell_sys.cmx omake_shell_job.cmx omake_shell_completion.cmx OCAML_LIB_FLAGS_shell = shell.cma: $(CMOFILES_shell) $(OCAMLC) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_shell) -a -o $@ $(CMOFILES_shell) shell.cmxa: $(CMXFILES_shell) $(OCAMLOPT) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_shell) -a -o $@ $(CMXFILES_shell) omake_shell_parse.ml: omake_shell_parse.mly omake_shell_parse.mli: omake_shell_parse.mly omake_shell_parse.cmo: omake_shell_parse.cmi omake_shell_parse.mly: ..$(slash)src$(slash)shell$(slash)omake_shell_parse.mly $(LN) ..$(slash)src$(slash)shell$(slash)omake_shell_parse.mly omake_shell_parse.mly omake_shell_sys.ml: ..$(slash)src$(slash)shell$(slash)omake_shell_sys_$(win32).ml $(LN) ..$(slash)src$(slash)shell$(slash)omake_shell_sys_$(win32).ml omake_shell_sys.ml Makefile.dep: omake_shell_parse.mli omake_shell_parse.ml omake_shell_sys.ml SRC_shell = ..$(slash)src$(slash)shell omake_shell_completion.ml: $(SRC_shell)$(slash)omake_shell_completion.ml $(LN) $(SRC_shell)$(slash)omake_shell_completion.ml omake_shell_completion.ml omake_shell_completion.mli: $(SRC_shell)$(slash)omake_shell_completion.mli $(LN) $(SRC_shell)$(slash)omake_shell_completion.mli omake_shell_completion.mli omake_shell_job.ml: $(SRC_shell)$(slash)omake_shell_job.ml $(LN) $(SRC_shell)$(slash)omake_shell_job.ml omake_shell_job.ml omake_shell_job.mli: $(SRC_shell)$(slash)omake_shell_job.mli $(LN) $(SRC_shell)$(slash)omake_shell_job.mli omake_shell_job.mli omake_shell_lex.ml: $(SRC_shell)$(slash)omake_shell_lex.ml $(LN) $(SRC_shell)$(slash)omake_shell_lex.ml omake_shell_lex.ml omake_shell_lex.mli: $(SRC_shell)$(slash)omake_shell_lex.mli $(LN) $(SRC_shell)$(slash)omake_shell_lex.mli omake_shell_lex.mli omake_shell_spawn.ml: $(SRC_shell)$(slash)omake_shell_spawn.ml $(LN) $(SRC_shell)$(slash)omake_shell_spawn.ml omake_shell_spawn.ml omake_shell_spawn.mli: $(SRC_shell)$(slash)omake_shell_spawn.mli $(LN) $(SRC_shell)$(slash)omake_shell_spawn.mli omake_shell_spawn.mli omake_shell_sys.mli: $(SRC_shell)$(slash)omake_shell_sys.mli $(LN) $(SRC_shell)$(slash)omake_shell_sys.mli omake_shell_sys.mli omake_shell_sys_type.ml: $(SRC_shell)$(slash)omake_shell_sys_type.ml $(LN) $(SRC_shell)$(slash)omake_shell_sys_type.ml omake_shell_sys_type.ml ALLFILES_shell = omake_shell_completion.ml omake_shell_completion.mli omake_shell_job.ml omake_shell_job.mli omake_shell_lex.ml omake_shell_lex.mli omake_shell_spawn.ml omake_shell_spawn.mli omake_shell_sys.mli omake_shell_sys_type.ml omake_shell_parse.mly omake_shell_sys.ml CMOFILES_eval = omake_eval.cmo omake_value.cmo CMXFILES_eval = omake_eval.cmx omake_value.cmx OCAML_LIB_FLAGS_eval = eval.cma: $(CMOFILES_eval) $(OCAMLC) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_eval) -a -o $@ $(CMOFILES_eval) eval.cmxa: $(CMXFILES_eval) $(OCAMLOPT) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_eval) -a -o $@ $(CMXFILES_eval) SRC_eval = ..$(slash)src$(slash)eval omake_eval.ml: $(SRC_eval)$(slash)omake_eval.ml $(LN) $(SRC_eval)$(slash)omake_eval.ml omake_eval.ml omake_eval.mli: $(SRC_eval)$(slash)omake_eval.mli $(LN) $(SRC_eval)$(slash)omake_eval.mli omake_eval.mli omake_value.ml: $(SRC_eval)$(slash)omake_value.ml $(LN) $(SRC_eval)$(slash)omake_value.ml omake_value.ml omake_value.mli: $(SRC_eval)$(slash)omake_value.mli $(LN) $(SRC_eval)$(slash)omake_value.mli omake_value.mli ALLFILES_eval = omake_eval.ml omake_eval.mli omake_value.ml omake_value.mli CMOFILES_build = omake_rule.cmo omake_build_type.cmo omake_build_tee.cmo omake_build_util.cmo omake_builtin_type.cmo omake_target.cmo omake_builtin.cmo omake_build.cmo CMXFILES_build = omake_rule.cmx omake_build_type.cmx omake_build_tee.cmx omake_build_util.cmx omake_builtin_type.cmx omake_target.cmx omake_builtin.cmx omake_build.cmx OCAML_LIB_FLAGS_build = build.cma: $(CMOFILES_build) $(OCAMLC) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_build) -a -o $@ $(CMOFILES_build) build.cmxa: $(CMXFILES_build) $(OCAMLOPT) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_build) -a -o $@ $(CMXFILES_build) omake_rule.cmx omake_build_type.cmx omake_build_tee.cmx omake_build_util.cmx omake_builtin_type.cmx omake_target.cmx omake_builtin.cmx omake_build.cmx omake_rule.cmo omake_build_type.cmo omake_build_tee.cmo omake_build_util.cmo omake_builtin_type.cmo omake_target.cmo omake_builtin.cmo omake_build.cmo omake_rule.cmi omake_build_tee.cmi omake_build_util.cmi omake_target.cmi omake_builtin.cmi omake_build.cmi: magic.cma SRC_build = ..$(slash)src$(slash)build omake_build.ml: $(SRC_build)$(slash)omake_build.ml $(LN) $(SRC_build)$(slash)omake_build.ml omake_build.ml omake_build.mli: $(SRC_build)$(slash)omake_build.mli $(LN) $(SRC_build)$(slash)omake_build.mli omake_build.mli omake_build_tee.ml: $(SRC_build)$(slash)omake_build_tee.ml $(LN) $(SRC_build)$(slash)omake_build_tee.ml omake_build_tee.ml omake_build_tee.mli: $(SRC_build)$(slash)omake_build_tee.mli $(LN) $(SRC_build)$(slash)omake_build_tee.mli omake_build_tee.mli omake_build_type.ml: $(SRC_build)$(slash)omake_build_type.ml $(LN) $(SRC_build)$(slash)omake_build_type.ml omake_build_type.ml omake_build_util.ml: $(SRC_build)$(slash)omake_build_util.ml $(LN) $(SRC_build)$(slash)omake_build_util.ml omake_build_util.ml omake_build_util.mli: $(SRC_build)$(slash)omake_build_util.mli $(LN) $(SRC_build)$(slash)omake_build_util.mli omake_build_util.mli omake_builtin.ml: $(SRC_build)$(slash)omake_builtin.ml $(LN) $(SRC_build)$(slash)omake_builtin.ml omake_builtin.ml omake_builtin.mli: $(SRC_build)$(slash)omake_builtin.mli $(LN) $(SRC_build)$(slash)omake_builtin.mli omake_builtin.mli omake_builtin_type.ml: $(SRC_build)$(slash)omake_builtin_type.ml $(LN) $(SRC_build)$(slash)omake_builtin_type.ml omake_builtin_type.ml omake_rule.ml: $(SRC_build)$(slash)omake_rule.ml $(LN) $(SRC_build)$(slash)omake_rule.ml omake_rule.ml omake_rule.mli: $(SRC_build)$(slash)omake_rule.mli $(LN) $(SRC_build)$(slash)omake_rule.mli omake_rule.mli omake_target.ml: $(SRC_build)$(slash)omake_target.ml $(LN) $(SRC_build)$(slash)omake_target.ml omake_target.ml omake_target.mli: $(SRC_build)$(slash)omake_target.mli $(LN) $(SRC_build)$(slash)omake_target.mli omake_target.mli ALLFILES_build = omake_build.ml omake_build.mli omake_build_tee.ml omake_build_tee.mli omake_build_type.ml omake_build_util.ml omake_build_util.mli omake_builtin.ml omake_builtin.mli omake_builtin_type.ml omake_rule.ml omake_rule.mli omake_target.ml omake_target.mli CMOFILES_builtin = omake_printf.cmo omake_builtin_util.cmo omake_builtin_base.cmo omake_builtin_arith.cmo omake_builtin_file.cmo omake_builtin_fun.cmo omake_builtin_io.cmo omake_builtin_io_fun.cmo omake_builtin_sys.cmo omake_builtin_target.cmo omake_builtin_shell.cmo omake_builtin_rule.cmo omake_builtin_object.cmo omake_builtin_test.cmo omake_builtin_ocamldep.cmo CMXFILES_builtin = omake_printf.cmx omake_builtin_util.cmx omake_builtin_base.cmx omake_builtin_arith.cmx omake_builtin_file.cmx omake_builtin_fun.cmx omake_builtin_io.cmx omake_builtin_io_fun.cmx omake_builtin_sys.cmx omake_builtin_target.cmx omake_builtin_shell.cmx omake_builtin_rule.cmx omake_builtin_object.cmx omake_builtin_test.cmx omake_builtin_ocamldep.cmx OCAML_LIB_FLAGS_builtin = -linkall builtin.cma: $(CMOFILES_builtin) $(OCAMLC) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_builtin) -a -o $@ $(CMOFILES_builtin) builtin.cmxa: $(CMXFILES_builtin) $(OCAMLOPT) $(OCAMLFLAGS) $(OCAML_LIB_FLAGS_builtin) -a -o $@ $(CMXFILES_builtin) omake_printf.cmx omake_builtin_util.cmx omake_builtin_base.cmx omake_builtin_arith.cmx omake_builtin_file.cmx omake_builtin_fun.cmx omake_builtin_io.cmx omake_builtin_io_fun.cmx omake_builtin_sys.cmx omake_builtin_target.cmx omake_builtin_shell.cmx omake_builtin_rule.cmx omake_builtin_object.cmx omake_builtin_test.cmx omake_builtin_ocamldep.cmx omake_printf.cmo omake_builtin_util.cmo omake_builtin_base.cmo omake_builtin_arith.cmo omake_builtin_file.cmo omake_builtin_fun.cmo omake_builtin_io.cmo omake_builtin_io_fun.cmo omake_builtin_sys.cmo omake_builtin_target.cmo omake_builtin_shell.cmo omake_builtin_rule.cmo omake_builtin_object.cmo omake_builtin_test.cmo omake_builtin_ocamldep.cmo omake_printf.cmi omake_builtin_util.cmi omake_builtin_base.cmi omake_builtin_arith.cmi omake_builtin_file.cmi omake_builtin_fun.cmi omake_builtin_io.cmi omake_builtin_io_fun.cmi omake_builtin_sys.cmi omake_builtin_target.cmi omake_builtin_shell.cmi omake_builtin_rule.cmi omake_builtin_object.cmi omake_builtin_test.cmi: magic.cma SRC_builtin = ..$(slash)src$(slash)builtin omake_builtin_arith.ml: $(SRC_builtin)$(slash)omake_builtin_arith.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_arith.ml omake_builtin_arith.ml omake_builtin_arith.mli: $(SRC_builtin)$(slash)omake_builtin_arith.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_arith.mli omake_builtin_arith.mli omake_builtin_base.ml: $(SRC_builtin)$(slash)omake_builtin_base.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_base.ml omake_builtin_base.ml omake_builtin_base.mli: $(SRC_builtin)$(slash)omake_builtin_base.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_base.mli omake_builtin_base.mli omake_builtin_file.ml: $(SRC_builtin)$(slash)omake_builtin_file.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_file.ml omake_builtin_file.ml omake_builtin_file.mli: $(SRC_builtin)$(slash)omake_builtin_file.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_file.mli omake_builtin_file.mli omake_builtin_fun.ml: $(SRC_builtin)$(slash)omake_builtin_fun.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_fun.ml omake_builtin_fun.ml omake_builtin_fun.mli: $(SRC_builtin)$(slash)omake_builtin_fun.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_fun.mli omake_builtin_fun.mli omake_builtin_io.ml: $(SRC_builtin)$(slash)omake_builtin_io.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_io.ml omake_builtin_io.ml omake_builtin_io.mli: $(SRC_builtin)$(slash)omake_builtin_io.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_io.mli omake_builtin_io.mli omake_builtin_io_fun.ml: $(SRC_builtin)$(slash)omake_builtin_io_fun.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_io_fun.ml omake_builtin_io_fun.ml omake_builtin_io_fun.mli: $(SRC_builtin)$(slash)omake_builtin_io_fun.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_io_fun.mli omake_builtin_io_fun.mli omake_builtin_object.ml: $(SRC_builtin)$(slash)omake_builtin_object.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_object.ml omake_builtin_object.ml omake_builtin_object.mli: $(SRC_builtin)$(slash)omake_builtin_object.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_object.mli omake_builtin_object.mli omake_builtin_ocamldep.ml: $(SRC_builtin)$(slash)omake_builtin_ocamldep.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_ocamldep.ml omake_builtin_ocamldep.ml omake_builtin_rule.ml: $(SRC_builtin)$(slash)omake_builtin_rule.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_rule.ml omake_builtin_rule.ml omake_builtin_rule.mli: $(SRC_builtin)$(slash)omake_builtin_rule.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_rule.mli omake_builtin_rule.mli omake_builtin_shell.ml: $(SRC_builtin)$(slash)omake_builtin_shell.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_shell.ml omake_builtin_shell.ml omake_builtin_shell.mli: $(SRC_builtin)$(slash)omake_builtin_shell.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_shell.mli omake_builtin_shell.mli omake_builtin_sys.ml: $(SRC_builtin)$(slash)omake_builtin_sys.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_sys.ml omake_builtin_sys.ml omake_builtin_sys.mli: $(SRC_builtin)$(slash)omake_builtin_sys.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_sys.mli omake_builtin_sys.mli omake_builtin_target.ml: $(SRC_builtin)$(slash)omake_builtin_target.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_target.ml omake_builtin_target.ml omake_builtin_target.mli: $(SRC_builtin)$(slash)omake_builtin_target.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_target.mli omake_builtin_target.mli omake_builtin_test.ml: $(SRC_builtin)$(slash)omake_builtin_test.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_test.ml omake_builtin_test.ml omake_builtin_test.mli: $(SRC_builtin)$(slash)omake_builtin_test.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_test.mli omake_builtin_test.mli omake_builtin_util.ml: $(SRC_builtin)$(slash)omake_builtin_util.ml $(LN) $(SRC_builtin)$(slash)omake_builtin_util.ml omake_builtin_util.ml omake_builtin_util.mli: $(SRC_builtin)$(slash)omake_builtin_util.mli $(LN) $(SRC_builtin)$(slash)omake_builtin_util.mli omake_builtin_util.mli omake_printf.ml: $(SRC_builtin)$(slash)omake_printf.ml $(LN) $(SRC_builtin)$(slash)omake_printf.ml omake_printf.ml omake_printf.mli: $(SRC_builtin)$(slash)omake_printf.mli $(LN) $(SRC_builtin)$(slash)omake_printf.mli omake_printf.mli ALLFILES_builtin = omake_builtin_arith.ml omake_builtin_arith.mli omake_builtin_base.ml omake_builtin_base.mli omake_builtin_file.ml omake_builtin_file.mli omake_builtin_fun.ml omake_builtin_fun.mli omake_builtin_io.ml omake_builtin_io.mli omake_builtin_io_fun.ml omake_builtin_io_fun.mli omake_builtin_object.ml omake_builtin_object.mli omake_builtin_ocamldep.ml omake_builtin_rule.ml omake_builtin_rule.mli omake_builtin_shell.ml omake_builtin_shell.mli omake_builtin_sys.ml omake_builtin_sys.mli omake_builtin_target.ml omake_builtin_target.mli omake_builtin_test.ml omake_builtin_test.mli omake_builtin_util.ml omake_builtin_util.mli omake_printf.ml omake_printf.mli CMOFILES_omake = omake_main_util.cmo omake_shell.cmo omake_main.cmo CMXFILES_omake = omake_main_util.cmx omake_shell.cmx omake_main.cmx OCAML_LIBS_omake = lm.cma frt.cma magic.cma ast.cma ir.cma env.cma exec.cma eval.cma shell.cma build.cma builtin.cma OCAML_LIBS_OPT_omake = lm.cmxa frt.cmxa magic.cmxa ast.cmxa ir.cmxa env.cmxa exec.cmxa eval.cmxa shell.cmxa build.cmxa builtin.cmxa OCAML_OTHER_LIBS_omake = unix.cma OCAML_OTHER_LIBS_OPT_omake = unix.cmxa OCAML_CLIBS_omake = clib$(EXT_LIB) OCAML_CCLIBS_omake = -cclib clib$(EXT_LIB) omake.byte$(EXE): $(CMOFILES_omake) $(OCAML_LIBS_omake) $(OCAML_CLIBS_omake) $(OCAMLC) $(OCAMLFLAGS) -custom -o $@ $(OCAML_CCLIBS_omake) $(OCAML_OTHER_LIBS_omake) $(THREADSLIB) $(OCAML_LIBS_omake) $(CMOFILES_omake) omake.opt$(EXE): $(CMXFILES_omake) $(OCAML_LIBS_OPT_omake) $(OCAML_CLIBS_omake) $(OCAMLOPT) $(OCAMLFLAGS) -o $@ $(OCAML_CCLIBS_omake) $(OCAML_OTHER_LIBS_OPT_omake) $(THREADSLIB_OPT) $(OCAML_LIBS_OPT_omake) $(CMXFILES_omake) omake$(EXE): omake$(PREFERRED)$(EXE) $(LN) omake$(PREFERRED)$(EXE) $@ omake_main_util.cmx omake_shell.cmx omake_main.cmx omake_main_util.cmo omake_shell.cmo omake_main.cmo omake_shell.cmi omake_main.cmi: magic.cma SRC_main = ..$(slash)src$(slash)main omake_main.ml: $(SRC_main)$(slash)omake_main.ml $(LN) $(SRC_main)$(slash)omake_main.ml omake_main.ml omake_main.mli: $(SRC_main)$(slash)omake_main.mli $(LN) $(SRC_main)$(slash)omake_main.mli omake_main.mli omake_main_util.ml: $(SRC_main)$(slash)omake_main_util.ml $(LN) $(SRC_main)$(slash)omake_main_util.ml omake_main_util.ml omake_shell.ml: $(SRC_main)$(slash)omake_shell.ml $(LN) $(SRC_main)$(slash)omake_shell.ml omake_shell.ml omake_shell.mli: $(SRC_main)$(slash)omake_shell.mli $(LN) $(SRC_main)$(slash)omake_shell.mli omake_shell.mli ALLFILES_main = omake_main.ml omake_main.mli omake_main_util.ml omake_shell.ml omake_shell.mli ALLFILES = $(ALLFILES_clib) $(ALLFILES_libmojave) $(ALLFILES_front) $(ALLFILES_magic) $(ALLFILES_ir) $(ALLFILES_exec) $(ALLFILES_ast) $(ALLFILES_env) $(ALLFILES_shell) $(ALLFILES_eval) $(ALLFILES_build) $(ALLFILES_builtin) $(ALLFILES_main) # # Create a dependency file # Makefile.dep: $(ALLFILES) $(OCAMLDEP) $(OCAMLINCLUDES) *.ml *.mli > Makefile.dep # # Clean up # clean: $(RM) *.cmo *.cmx *.cma *.cmxa *.o *.obj *.a *.lib *.exe $(RM) $(ALLFILES) $(RM) omake include Makefile.dep omake-0.10.3/src/exec/0000755000175000017500000000000013177364666013051 5ustar gerdgerdomake-0.10.3/src/exec/OMakefile0000644000175000017500000000050213177364665014624 0ustar gerdgerdOCAMLINCLUDES[] += ../libmojave ../util ../ir FILES[] = omake_exec_id omake_exec_type omake_exec_print omake_exec_util omake_exec_local omake_exec_remote omake_exec_notify omake_exec MakeOCamlLibrary(exec, $(FILES)) clean: $(CLEAN) # # Generate a Makefile # MakeMakefile() omake-0.10.3/src/exec/omake_exec_notify.ml0000644000175000017500000001131213177364665017070 0ustar gerdgerd(* * File notification server. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004-2007 Mojave Group, Caltifornia Institute of Technology, * and HRL Laboratories, LLC * * 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; version 2 * of the License. * * 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, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * * Additional permission is given to link this library with the * with the Objective Caml runtime, and to redistribute the * linked executables. See the file LICENSE.OMake for more details. * * Author: Jason Hickey @email{jyh@cs.caltech.edu} * Modified By: Aleksey Nogin @email{anogin@hrl.com} * @end[license] *) open Omake_node open Omake_exec_type module Notify = struct (* * Notification services are performed by Lm_notify. *) type ('exp, 'pid, 'value) t = { mutable notify_server : Lm_notify.t option; mutable notify_event : Lm_notify.event option } (* * Create the server. * Initially disconnected. *) let create _ = { notify_server = None; notify_event = None } (* * Close it. *) let close notify = match notify.notify_server with Some server -> Lm_notify.close server; notify.notify_server <- None; notify.notify_event <- None | None -> () (* * Monitor a directory. *) let start notify = match notify.notify_server with Some server -> server | None -> let server = Lm_notify.create () in notify.notify_server <- Some server; server let monitor notify node = let dir = Dir.absname (Node.dir node) in let server = start notify in Lm_notify.monitor server dir false let monitor_tree notify dir = let dir = Dir.absname dir in let server = start notify in Lm_notify.monitor server dir true (* * Get the next event. * This assumes a notification thread is not currently running. *) let pending notify = match notify with { notify_event = Some _ ; _} -> true | { notify_server = Some server ; _} -> Lm_thread_pool.blocking_section Lm_notify.pending server | { notify_server = None ; _} -> false let next_event notify = match notify with { notify_event = Some event ; _} -> notify.notify_event <- None; event | { notify_server = Some server ; _ } -> Lm_thread_pool.blocking_section (Lm_thread.Thread.raise_ctrl_c_wrapper Lm_notify.next_event) server | { notify_server = None ; _} -> raise (Failure "Omake_exec_notify.next_event: no monitors") (* * Notify server does not implement processes. *) let spawn _ _ _ _ _ _ _ = raise (Invalid_argument "Omake_exec_notify.spawn: processes are not supported") (* * File descriptors. *) let descriptors notify = match Lm_notify.enabled, notify with true, { notify_event = None; notify_server = Some server } -> begin match Lm_notify.file_descr server with Some fd -> [fd] | None -> (* We are probabaly on Win32? *) [Unix.stdin] end | _ -> [] (* * Handle input from the descriptor. *) let handle notify _ _ = match notify with { notify_event = None; notify_server = Some server } when Lm_notify.pending server -> let event = Lm_thread_pool.blocking_section Lm_notify.next_event server in notify.notify_event <- Some event; false | _ -> false let handle_eof _ _ _ = () let acknowledge_eof _ _ _ = () (* * Wait for a command to finish. *) let wait notify _ = ignore(handle notify () ()); (* XXX HACK: nogin *) match notify.notify_event with Some event -> notify.notify_event <- None; WaitInternalNotify event | None -> WaitInternalNone end (* * -*- * Local Variables: * End: * -*- *) omake-0.10.3/src/exec/omake_exec_remote.ml0000644000175000017500000003455413177364665017070 0ustar gerdgerd(* * Remote execution of jobs. This includes both the job server * as well as the server handler. * *) (* FIXME: the remote servers never terminate regularly *) open Lm_printf open Lm_debug (* open Omake_util *) open Omake_node open Omake_state open Omake_exec_id open Omake_exec_util open Omake_exec_type (* * Build debugging. *) let debug_remote = create_debug (**) { debug_name = "remote"; debug_description = "Remote execution debugging"; debug_value = false } (* * Type of messages sent to the service. *) type ('exp, 'pid, 'value) request = RequestSpawn of Omake_exec_id.t * Node.t * 'exp (* * Type of messages received from the remote server. *) type ('exp, 'pid, 'value) response = ResponseCreate of bool | ResponseExited of Omake_exec_id.t * int * 'value | ResponseStdout of Omake_exec_id.t * bytes | ResponseStderr of Omake_exec_id.t * bytes | ResponseStatus of Omake_exec_id.t * ('exp, 'pid, 'value) print_flag (* * A local exception when the connection fails. *) (* * During login, there is a synchronization string. *) let sync_char = '\255' let sync_string = "\255OMake Remote Execution Protocol Version 1.0" (************************************************************************ * Printing. *) (* let pp_print_command_line buf (shell, command) = *) (* shell.shell_print_exp buf command *) (* let pp_print_command_lines buf (shell, commands) = *) (* List.iter (fun exp -> fprintf buf "@ %a" shell.shell_print_exp exp) commands *) (* let pp_print_request _buf (shell, request) = *) (* match request with *) (* RequestSpawn (id, target, commands) -> *) (* eprintf "@[@[RequestSpawn {@ id = %a;@ target = %a;@ @[commands = %a@]@]@ }@]" (\**\) *) (* pp_print_pid id *) (* pp_print_node target *) (* pp_print_command_lines (shell, commands) *) (* let pp_print_flag buf (shell, flag) = *) (* match flag with *) (* PrintEager command -> *) (* fprintf buf "@[Eager@ %a@]" pp_print_command_line (shell, command) *) (* | PrintLazy command -> *) (* fprintf buf "@[Lazy@ %a@]" pp_print_command_line (shell, command) *) (* | PrintExit (command, code, _, time) -> *) (* fprintf buf "@[Exit %d,@ %a,@ %a@]" code pp_time time pp_print_command_line (shell, command) *) (* let pp_print_response _buf (shell, response) = *) (* match response with *) (* ResponseCreate flag -> *) (* eprintf "ResponseCreate %b" flag *) (* | ResponseExited (id, code, _) -> *) (* eprintf "ResponseExited (%a, %d)" pp_print_pid id code *) (* | ResponseStdout (id, s) -> *) (* eprintf "ResponseStdout (%a, \"%s\")" pp_print_pid id (String.escaped s) *) (* | ResponseStderr (id, s) -> *) (* eprintf "ResponseStderr (%a, \"%s\")" pp_print_pid id (String.escaped s) *) (* | ResponseStatus (id, flag) -> *) (* eprintf "@[@[ResponseStatus {@ id = %a;@ flag = %a@]@ }@]" (\**\) *) (* pp_print_pid id *) (* pp_print_flag (shell, flag) *) module Server = struct (************************************************************************ * Data is marshaled. *) let stdin = Pervasives.stdin let stdout = Pervasives.stdout (* * Send the sync string. *) let send_sync () = Pervasives.output_string stdout sync_string; Pervasives.flush stdout (* * The actual marshalers. *) let sendmsg out msg = Marshal.to_channel out msg []; Pervasives.flush out let send_response response = sendmsg stdout response let send_request = sendmsg (* * Receive a message. *) let recvmsg inx = Marshal.from_channel inx let recv_request () = recvmsg stdin let recv_response = recvmsg (************************************************************************ * Remote server. *) (* * Handle output. *) let handle_stdout id buf off len = send_response (ResponseStdout (id, Bytes.sub buf off len)) let handle_stderr id buf off len = send_response (ResponseStderr (id, Bytes.sub buf off len)) let handle_status id flag = send_response (ResponseStatus (id, flag)) (* * We don't evaluate commands remotely. *) (* let eval _ = *) (* raise (Invalid_argument "Omake_exec_remote.eval") *) (* * Start a process. *) let handle_spawn local shell id target commands = let code = Omake_exec_local.spawn (**) local shell id handle_stdout handle_stderr handle_status target commands in match code with | ProcessFailed -> send_response (ResponseExited (id, fork_error_code, shell.shell_error_value)) | ProcessStarted _ -> (* Remote server already assumed it started *) () (* * Handle input from a descriptor. * Special case if input is from stdin. *) let handle local shell options fd = if !debug_remote then eprintf "*** server: got input on fd %d@." (Obj.magic fd); if fd = Unix.stdin then match recv_request () with RequestSpawn (id, target, commands) -> handle_spawn local shell id target commands else let closed = Omake_exec_local.handle local options fd in if closed then ( Omake_exec_local.acknowledge_eof local options fd; Omake_exec_local.handle_eof local options fd ) (* * Serve. *) let rec serve local shell options = match Omake_exec_local.wait local options with | WaitInternalExited (id, code, value) -> send_response (ResponseExited (id, code, value)); serve local shell options | WaitInternalNotify _ -> raise (Invalid_argument "Omake_exec_remote.serve: received notify message") | WaitInternalStarted _ -> raise (Invalid_argument "Omake_exec_remote.serve: received started message") | WaitInternalNone -> let fd_read = Unix.stdin :: Omake_exec_local.descriptors local in let fd_read = try let fd_read, _, _ = Unix.select fd_read [] [] (-1.0) in fd_read with Unix.Unix_error _ -> [] in List.iter (handle local shell options) fd_read; serve local shell options (* * Remote service. *) let main_exn shell options = (* First, synchronize with the server *) if !debug_remote then eprintf "*** server: starting@."; send_sync (); send_response (ResponseCreate true); serve (Omake_exec_local.create "local") shell options let main shell options = try main_exn shell options with exn -> eprintf "@[*** server: uncaught exception:@ %s@]@." (Printexc.to_string exn); exit exn_error_code end (************************************************************************ * Remote service. *) (* * Status of a job. *) type 'value job_state = JobRunning | JobFinished of int * 'value (* * A Job has some handlers. *) type ('exp, 'pid, 'value) job = { job_id : Omake_exec_id.t; job_handle_out : output_fun; job_handle_err : output_fun; job_handle_status : ('exp, 'pid, 'value) status_fun; job_shell : ('exp, 'pid, 'value) shell; mutable job_state : 'value job_state } (* * Server state. *) type server_state = ServerConnecting of int | ServerSynced | ServerConnected of bool | ServerRunning (* * The state is an ssh channel. *) type ('exp, 'pid, 'value) t = { server_out : Pervasives.out_channel; server_in : Pervasives.in_channel; server_pid : int; (* Keep track of running jobs, so we can kill them if the connection drops *) mutable server_state : server_state; mutable server_jobs : ('exp, 'pid, 'value) job IdTable.t } (* * Wrap the message calls. *) let send_request server request = Server.send_request server.server_out request let recv_response server = Server.recv_response server.server_in (* * Create a new service. *) let create hostname = let flags = if !debug_remote then "-debug-remote" else "" in let cmd = Printf.sprintf "omake %s -server %s" flags (Dir.absname (Dir.cwd ())) in let ssh = "ssh" in let cmd = [|ssh; hostname; cmd|] in (* Create the pipes *) with_pipe (fun stdin_read stdin_write -> with_pipe (fun stdout_read stdout_write -> let pid = Unix.create_process ssh cmd stdin_read stdout_write Unix.stderr in let server = { server_out = Unix.out_channel_of_descr stdin_write; server_in = Unix.in_channel_of_descr stdout_read; server_pid = pid; server_state = ServerConnecting 0; server_jobs = IdTable.empty } in Unix.close stdin_read; Unix.close stdout_write; server)) (* * Close the connection. *) let close server = let { server_out = requestc; server_in = responsec; server_pid = pid; _ } = server in let () = try Unix.kill pid Sys.sigterm with Unix.Unix_error _ -> () in Pervasives.close_out requestc; Pervasives.close_in responsec (* * Start a new job. *) let spawn server shell id handle_out handle_err handle_status target commands = if !debug_remote then eprintf "*** remote: spawn: %a@." pp_print_node target; (* Send the request to the remote server *) send_request server (RequestSpawn (id, target, commands)); (* Pretend that the job started *) let job = { job_id = id; job_shell = shell; job_handle_out = handle_out; job_handle_err = handle_err; job_handle_status = handle_status; job_state = JobRunning } in server.server_jobs <- IdTable.add server.server_jobs id job; ProcessStarted id (* * Get descriptors. *) let descriptors server = [Unix.descr_of_in_channel server.server_in] (* * A job exited. *) let handle_exit server id code value = let job = try IdTable.find server.server_jobs id with Not_found -> raise (Invalid_argument "Omake_exec_remote.handle_exit: no such job") in job.job_state <- JobFinished (code, value); false (* * Handle data from stdout. *) let handle_stdout server id buf = let job = try IdTable.find server.server_jobs id with Not_found -> raise (Invalid_argument "Omake_exec_remote.handle_stdout: no such job") in let { job_handle_out = handle_out ; _} = job in handle_out id buf 0 (Bytes.length buf); false let handle_stderr server id buf = let job = try IdTable.find server.server_jobs id with Not_found -> raise (Invalid_argument "Omake_exec_remote.handle_stderr: no such job") in let { job_handle_err = handle_err ; _} = job in handle_err id buf 0 (Bytes.length buf); false let handle_status server id flag = let job = try IdTable.find server.server_jobs id with Not_found -> raise (Invalid_argument "Omake_exec_remote.handle_status: no such job") in let { job_handle_status = handle_status ; _} = job in handle_status id flag; false (* * Handle input. *) let handle_normal server _fd = if !debug_remote then eprintf "*** handle_normal@."; match recv_response server with ResponseCreate succeeded -> server.server_state <- ServerConnected succeeded; not succeeded | ResponseExited (id, code, value) -> handle_exit server id code value | ResponseStdout (id, buf) -> handle_stdout server id buf | ResponseStderr (id, buf) -> handle_stderr server id buf | ResponseStatus (id, flag) -> handle_status server id flag let handle server _options fd = let { server_state = state; server_in = responsec; _ } = server in match state with ServerConnecting i -> (try let c = input_char responsec in if c = sync_char then server.server_state <- ServerConnecting 1 else if c = sync_string.[i] then if i = pred (String.length sync_string) then let () = if !debug_remote then eprintf "*** remote: server is synced@." in server.server_state <- ServerSynced else server.server_state <- ServerConnecting (succ i) else server.server_state <- ServerConnecting 0; false with End_of_file -> server.server_state <- ServerConnected false; true) | ServerSynced | ServerConnected _ | ServerRunning -> handle_normal server fd let handle_eof _ _ _ = () let acknowledge_eof _ _ _ = () (* * Find a finished job, or raise Not_found if there is none. *) let wait_for_job server = let search _ job = match job with { job_id = id; job_state = JobFinished (code, value) ; _} -> Some (id, code, value) | { job_state = JobRunning ; _} -> None in match IdTable.find_iter search server.server_jobs with Some (id, code, value) -> server.server_jobs <- IdTable.remove server.server_jobs id; WaitInternalExited (id, code, value) | None -> WaitInternalNone let wait server _options = if !debug_remote then eprintf "*** remote: wait@."; match server.server_state with ServerConnecting _ | ServerSynced -> WaitInternalNone | ServerConnected succeeded -> server.server_state <- ServerRunning; WaitInternalStarted succeeded | ServerRunning -> wait_for_job server let main = Server.main omake-0.10.3/src/exec/omake_exec_util.ml0000644000175000017500000000676113177364665016551 0ustar gerdgerd(* * Utilities for execution. *) (* open Lm_printf *) (* * Build debugging. *) let debug_exec = Lm_debug.create_debug (**) { debug_name = "exec"; debug_description = "Display execution debugging"; debug_value = false } module IntTable = Lm_map.LmMake (struct type t = int let compare = (-) end) module FdTable = Lm_map.LmMake (struct type t = Unix.file_descr let compare = Pervasives.compare end );; let unix_close fd = try Unix.close fd with Unix.Unix_error _ -> () let with_pipe f = let read, write = Unix.pipe () in try f read write with exn -> unix_close read; unix_close write; raise exn (* * Write the data in the buffer to the channel. *) let write_all name fd _id buf off len = if len <> 0 then match Unix.write fd buf off len with | amount when amount <> len -> Format.eprintf "Writing to %s was only partially successful (%i out of %i written)@." name amount len; invalid_arg "Omake_exec_util.write_all" | exception Unix.Unix_error (err1, err2, err3) -> Format.eprintf "Writing to %s resulted in an error: %s: %s: %s@." name err2 err3 (Unix.error_message err1); invalid_arg "Omake_exec_util.write_all" | _ -> () (* * Copy output to a file. *) let copy_file name = let fd_out = Lm_unix_util.openfile name [O_WRONLY; O_CREAT; O_TRUNC] 0o666 in let () = Unix.set_close_on_exec fd_out in let copy id buf off len = if len = 0 then Unix.close fd_out else write_all name fd_out id buf off len in copy (* * Tee the output to a file if any occurs. * The files are created only if there is output. *) type tee_info = | TeeChannel of string * Pervasives.out_channel | TeeFile of string | TeeMaybe | TeeNever type tee = tee_info ref let tee_file tee = match !tee with | TeeChannel (name, _) | TeeFile name -> Some name | TeeMaybe | TeeNever -> None let tee_channel tee = match !tee with | TeeChannel (_, outx) -> Some outx | TeeMaybe -> let filename, outx = Filename.open_temp_file ~mode:[Open_binary;Open_append] "omake" ".divert" in tee := TeeChannel (filename, outx); Some outx | TeeFile _ | TeeNever -> None let tee_close tee = match !tee with | TeeChannel (name, outx) -> Pervasives.close_out outx; tee := TeeFile name | TeeFile _ | TeeMaybe | TeeNever -> () let tee_none = ref TeeNever let tee_create (b : bool) : tee = if b then ref TeeMaybe else tee_none let tee_copy name fd flush_flag tee tee_only id buf off len = if len = 0 then begin if not tee_only then flush_flag := true; match !tee with | TeeChannel (_, outx) -> Pervasives.flush outx | _ -> () end else begin if not tee_only then begin if !flush_flag then begin Omake_exec_print.progress_flush (); flush_flag := false; end; write_all name fd id buf off len; end; match tee_channel tee with Some outx -> Pervasives.output outx buf off len | None -> () end let tee_file_descr tee = match tee_channel tee with | Some outx -> Some(Unix.descr_of_out_channel outx) | None -> None let tee_stdout = tee_copy "Unix.stdout" Unix.stdout (ref true) let tee_stderr = tee_copy "Unix.stderr" Unix.stderr (ref true) omake-0.10.3/src/exec/omake_exec_type.ml0000644000175000017500000001300613177364665016543 0ustar gerdgerd(* * Execution codes. * *) (* open Omake_options *) (* * Type of process codes. *) type process_code = ProcessFailed | ProcessStarted of Omake_exec_id.t (* * Print flags. *) type ('exp, 'pid, 'value) print_flag = PrintEager of 'exp | PrintLazy of 'exp | PrintExit of 'exp * int * 'value * float (* * Internal wait status. *) type ('exp, 'pid, 'value) wait_internal_code = WaitInternalExited of Omake_exec_id.t * int * 'value | WaitInternalNotify of Lm_notify.event | WaitInternalStarted of bool | WaitInternalNone (* * External wait status. * WaitServer count: a new server started, willing to serve "count" more jobs *) type ('exp, 'pid, 'value) wait_code = | WaitExited of Omake_exec_id.t * int * 'value | WaitServer of int | WaitNotify of Lm_notify.event | WaitNone (* * Types of upcalls. *) type ('exp, 'pid, 'value) shell = { shell_eval : Unix.file_descr -> Unix.file_descr -> 'exp -> 'pid; shell_eval_is_nop : 'exp -> bool; shell_eval_is_cmd : 'exp -> bool; shell_info : 'exp -> Omake_command_type.command_flag list * Omake_node.Dir.t * Omake_node.Node.t; shell_kill : 'pid -> unit; shell_wait : 'pid -> Unix.process_status * 'value; shell_error_value : 'value; shell_print_exp : 'exp Lm_printf.t; shell_print_exn : exn Lm_printf.t ; shell_is_failure_exn : exn -> bool } type ('exp, 'pid, 'value) status_fun = Omake_exec_id.t -> ('exp, 'pid, 'value) print_flag -> unit type output_fun = Omake_exec_id.t -> bytes -> int -> int -> unit (* * Internal execution server has a few extra functions. *) module type ExecServer = sig (* * Command processor. *) type ('exp, 'pid, 'value) t (* * Create the processor. * The directory is the current working root directory. *) val create : string -> ('exp, 'pid, 'value) t (* * Close it, and possibly deallocate state. *) val close : ('exp, 'pid, 'value) t -> unit (* * Start a command, and return the process ID. *) val spawn : ('exp, 'pid, 'value) t -> (* Current state *) ('exp, 'pid, 'value) shell -> (* The shell that does evaluation *) Omake_exec_id.t -> (* Id for the new process *) output_fun -> (* Function to handle output from stdout *) output_fun -> (* Function to handle output from stderr *) ('exp, 'pid, 'value) status_fun -> (* Function to handle status commands *) Omake_node.Node.t -> (* Target being built *) 'exp list -> (* Commands to execute *) process_code (* The process id *) (* * The internal versions are polled using select. *) val descriptors : ('exp, 'pid, 'value) t -> Unix.file_descr list (* * Handle input from one of the descriptors. Returns true on EOF. This * function can run in a thread. *) val handle : ('exp, 'pid, 'value) t -> Omake_options.t -> Unix.file_descr -> bool (* * Synchronizing point for EOF. *) val acknowledge_eof : ('exp, 'pid, 'value) t -> Omake_options.t -> Unix.file_descr -> unit (* * Special actions for EOF. (Including closing fd's.) *) val handle_eof : ('exp, 'pid, 'value) t -> Omake_options.t -> Unix.file_descr -> unit (* * Wait for any one of the commands to finish. *) val wait : ('exp, 'pid, 'value) t -> Omake_options.t -> ('exp, 'pid, 'value) wait_internal_code end (* * The execution service. *) module type ExecService = sig (* * Command processor. *) type ('exp, 'pid, 'value) t (* * Create the processor. * The directory is the current working root directory. *) val create : Omake_node.Dir.t -> Omake_options.t -> ('exp, 'pid, 'value) t (* * Close it, and possibly deallocate state. *) val close : ('exp, 'pid, 'value) t -> unit (* * Start a command, and return the process ID. *) val spawn : ('exp, 'pid, 'value) t -> (* Current state *) ('exp, 'pid, 'value) shell -> (* Evaluate a shell command *) Omake_options.t -> (* Current options in effect *) output_fun -> (* Function to handle the OMake messages meant for stdout *) output_fun -> (* Function to handle output from stdout *) output_fun -> (* Function to handle output from stderr *) string -> (* Name of this command *) Omake_node.Node.t -> (* Target being built *) 'exp list -> (* Commands to execute *) process_code (* The process id *) (* * Wait for any one of the commands to finish. *) val wait : ?onblock:(unit->unit) -> ('exp, 'pid, 'value) t -> Omake_options.t -> ('exp, 'pid, 'value) wait_code (* * Notify when a file changes. *) val monitor : ('exp, 'pid, 'value) t -> Omake_node.Node.t -> unit val monitor_tree : ('exp, 'pid, 'value) t -> Omake_node.Dir.t -> unit (* * Get the next file change notification. * This function blocks. Use wait if you want * nonblocking behavior. *) val pending : ('exp, 'pid, 'value) t -> bool val next_event : ('exp, 'pid, 'value) t -> Lm_notify.event end omake-0.10.3/src/exec/omake_exec.ml0000644000175000017500000004113513177364665015506 0ustar gerdgerd(* * Execution service. This is the wrapper around the remote * and local servers. *) open Lm_printf open Lm_thread_pool open Omake_node open Omake_exec_util open Omake_exec_type open Omake_exec_print open Omake_exec_remote open Omake_exec_notify open Omake_options module Exec = struct (* * Local and remote servers. *) type ('venv, 'exp, 'value) server_handle = LocalServer of ('venv, 'exp, 'value) Omake_exec_local.t | RemoteServer of ('venv, 'exp, 'value) Omake_exec_remote.t | NotifyServer of ('venv, 'exp, 'value) Notify.t (* * Information about the local server * server_count : number of jobs that can be run on this server * server_handle : handle for the actual server * server_running : number of jobs that are actually running * server_enabled : is server connected and ready? *) type ('venv, 'exp, 'value) server_info = { server_host : string; server_count : int; server_handle : ('venv, 'exp, 'value) server_handle; mutable server_running : int; mutable server_enabled : bool } (* * The state: * server_root : location of the project root * server_local : local execution server * server_servers : all the servers * * Invariant: server_jobs and server_fds are equivalent * server_jobs : used with threads, a list of the currently active threads * server_fds : used with threads, a list of the currently active files *) type ('venv, 'exp, 'value) t = { server_root : Dir.t; server_local : ('venv, 'exp, 'value) Omake_exec_local.t; server_notify : ('venv, 'exp, 'value) Notify.t; mutable server_servers : ('venv, 'exp, 'value) server_info list; mutable server_fd_table : ('venv, 'exp, 'value) server_info FdTable.t; mutable server_pid_table : Unix.file_descr IntTable.t } (* * Start a remote server. *) let start_local local options = { server_host = "localhost"; server_count = opt_job_count options; server_running = 0; server_enabled = true; server_handle = LocalServer local } let start_notify notify _options = { server_host = "notify"; server_count = 0; server_running = 0; server_enabled = true; server_handle = NotifyServer notify } let start_remote _root (machine, count) = { server_host = machine; server_count = count; server_running = 0; server_enabled = false; server_handle = RemoteServer (Omake_exec_remote.create machine) } let create root options = let local = Omake_exec_local.create "local" in let notify = Notify.create "notify" in let servers = start_local local options :: start_notify notify options :: List.map (start_remote root) (opt_remote_servers options) in { server_root = root; server_local = local; server_notify = notify; server_servers = servers; server_fd_table = FdTable.empty; server_pid_table = IntTable.empty } (* * When the server is closed, kill all the jobs. *) let close server = List.iter (fun { server_handle = handle ; _} -> match handle with LocalServer local -> Omake_exec_local.close local | RemoteServer remote -> Omake_exec_remote.close remote | NotifyServer notify -> Notify.close notify) server.server_servers (* * Print the status. *) let print_status tee options shell remote name _ = let remote = match remote with { server_handle = LocalServer _ ; _} | { server_handle = NotifyServer _ ; _} -> None | { server_host = host; server_handle = RemoteServer _ ; _} -> Some host in print_status tee options shell remote name (* * Find the best server. *) let find_best_server server = if !debug_remote then List.iter (fun { server_host = host; server_count = count; server_running = running; server_enabled = enabled; _ } -> eprintf "*** searching %s, count=%d, running=%d, enabled=%b@." host count running enabled) server.server_servers; let rec search best servers = match servers with server :: servers -> let { server_enabled = enabled; server_count = count; server_running = running; _ } = server in let best = if enabled && running <> count then match best with Some { server_running = running' ; _} -> if running < running' then Some server else best | None -> Some server else best in search best servers | [] -> best in match search None server.server_servers with Some server -> server | None -> raise (Invalid_argument "Omake_exec.find_best_server: all servers are disabled") (* * Start a job. *) let spawn server_main shell options handle_sys_out handle_out handle_err name target commands = (* Start the job *) let id = Omake_exec_id.create () in let server = find_best_server server_main in let { server_running = running; server_handle = handle; _ } = server in (* Handle a status message *) let handle_status = print_status (handle_sys_out id) options shell server name in (* Start the job *) let status = match handle with LocalServer local -> Omake_exec_local.spawn local shell id handle_out handle_err handle_status target commands | RemoteServer remote -> Omake_exec_remote.spawn remote shell id handle_out handle_err handle_status target commands | NotifyServer notify -> Notify.spawn notify shell id handle_out handle_err handle_status target commands in let () = match status with ProcessStarted _ -> server.server_running <- succ running | ProcessFailed -> () in status let acknowledge_eof server_info options fd = match server_info.server_handle with | LocalServer local -> Omake_exec_local.acknowledge_eof local options fd | RemoteServer _ -> () | NotifyServer _ -> () let handle_eof server_info options fd = match server_info.server_handle with | LocalServer local -> Omake_exec_local.handle_eof local options fd | RemoteServer _ -> () | NotifyServer _ -> () let likely_blocking server_main = (* whether it is likely that we'll block the next time we wait *) List.exists (fun server_info -> match server_info.server_handle with | LocalServer local -> Omake_exec_local.likely_blocking local | RemoteServer _ -> true | NotifyServer _ -> false ) server_main.server_servers (* * Select-based waiting. * Wait for input on one of the servers. *) let wait_select server options = let { server_notify = _notify; server_servers = servers; _ } = server in let fd_table = List.fold_left (fun fd_table server -> let fd_set = match server.server_handle with | LocalServer local -> Omake_exec_local.descriptors local | RemoteServer remote -> Omake_exec_remote.descriptors remote | NotifyServer notify -> Notify.descriptors notify in List.fold_left (fun fd_table fd -> FdTable.add fd_table fd server ) fd_table fd_set ) FdTable.empty servers in let fd_set = FdTable.fold (fun fd_set fd _ -> fd :: fd_set) [] fd_table in let fd_set = try let fd_set, _, _ = Unix.select fd_set [] [] (-1.0) in fd_set with Unix.Unix_error (errno, s1, s2) -> eprintf "Select: %s, %s, %s@." s1 s2 (Unix.error_message errno); [] in let actions = List.map (fun fd -> let server = try Some (FdTable.find fd_table fd) with Not_found -> eprintf "Omake_exec.wait_select: fd is unknown: %d@." (Obj.magic fd); None in let got_eof = match server with | Some { server_handle = LocalServer local ; _} -> Omake_exec_local.handle local options fd | Some { server_handle = RemoteServer remote ; _} -> Omake_exec_remote.handle remote options fd | Some { server_handle = NotifyServer notify ; _} -> Notify.handle notify options fd | None -> false in if got_eof then match server with | Some si -> acknowledge_eof si options fd; (fun () -> handle_eof si options fd) | None -> assert false else (fun () -> ()) ) fd_set in List.iter (fun f -> f()) actions; WaitNone (* * Thread-based waiting. *) let start_handler server_info handler (pid_table, fd_table) fd = if FdTable.mem fd_table fd then pid_table, fd_table else ( let pid = Lm_thread_pool.create true (fun () -> ignore(handler fd)) in let fd_table = FdTable.add fd_table fd server_info in let pid_table = IntTable.add pid_table pid fd in if !debug_thread then eprintf "start_handler: %d@." (Lm_unix_util.int_of_fd fd); pid_table, fd_table ) let wait_thread server options = let { server_servers = servers; server_fd_table = fd_table; server_pid_table = pid_table; _ } = server in (* Spawn a thread for each file descriptor *) let pid_table, fd_table = List.fold_left (fun tables server_info -> match server_info.server_handle with | LocalServer local -> List.fold_left (start_handler server_info (Omake_exec_local.handle local options)) tables (Omake_exec_local.descriptors local) | RemoteServer remote -> List.fold_left (start_handler server_info (Omake_exec_remote.handle remote options)) tables (Omake_exec_remote.descriptors remote) | NotifyServer notify -> List.fold_left (start_handler server_info (Notify.handle notify options)) tables (Notify.descriptors notify) ) (pid_table, fd_table) servers in let pids = Lm_thread_pool.wait () in (* A thread finishes when it got an event *) let old_fd_table = fd_table in let pid_table, fd_table, event_fd_list = List.fold_left (fun (pid_table, fd_table, event_fd_list) pid -> try let fd = IntTable.find pid_table pid in let pid_table = IntTable.remove pid_table pid in let fd_table = FdTable.remove fd_table fd in pid_table, fd_table, fd::event_fd_list with Not_found -> (* BUG JYH: we seem to be getting unknown pids... *) pid_table, fd_table, event_fd_list ) (pid_table, fd_table, []) pids in server.server_fd_table <- fd_table; server.server_pid_table <- pid_table; (* Now that the fd's have been removed from the tables, we can ack any eofs seen *) let ack_eof fd = let server_info = FdTable.find old_fd_table fd in acknowledge_eof server_info options fd in List.iter ack_eof event_fd_list; (* Maybe some fd's are at eof: *) let hdl_eof fd = if !Omake_exec_util.debug_exec then eprintf "postprocessing fd %d@." (Lm_unix_util.int_of_fd fd); let server_info = FdTable.find old_fd_table fd in handle_eof server_info options fd in List.iter hdl_eof event_fd_list; WaitNone (* * Wait for all threads to finish. *) let wait_all server = let { server_pid_table = pid_table ; _} = server in let rec wait pid_table = if not (IntTable.is_empty pid_table) then let pids = Lm_thread_pool.wait () in let pid_table = List.fold_left IntTable.remove pid_table pids in wait pid_table in wait pid_table; server.server_pid_table <- IntTable.empty; server.server_fd_table <- FdTable.empty (* * The wait process handles output from each of the jobs. * Once both output channels are closed, the job is finished. *) let wait ?(onblock=fun() -> ()) server_main options = let rec poll servers = match servers with [] -> if likely_blocking server_main then onblock(); if Lm_thread_pool.enabled then wait_thread server_main options else wait_select server_main options | server :: servers -> let { server_host = host; server_count = count; server_running = running; server_handle = handle; _ } = server in let wait_code = match handle with LocalServer local -> Omake_exec_local.wait local options | RemoteServer remote -> Omake_exec_remote.wait remote options | NotifyServer notify -> Notify.wait notify options in match wait_code with WaitInternalExited (id, status, value) -> server.server_running <- pred running; WaitExited (id, status, value) | WaitInternalStarted true -> if opt_print_status options then begin progress_flush (); printf "# server %s started@." host end; server.server_enabled <- true; WaitServer count | WaitInternalStarted false -> if opt_print_status options then begin progress_flush (); printf "# server %s failed@." host end; server.server_enabled <- false; poll servers | WaitInternalNotify event -> WaitNotify event | WaitInternalNone -> poll servers in poll server_main.server_servers (* * Ask for a file to be monitored. *) let monitor { server_notify = notify ; _} node = Notify.monitor notify node let monitor_tree { server_notify = notify ; _} dir = Notify.monitor_tree notify dir (* * Wait for the next notification. * Wait for all threads to complete * before issuing this command. *) let pending server = wait_all server; Notify.pending server.server_notify let next_event server = wait_all server; Notify.next_event server.server_notify end omake-0.10.3/src/exec/omake_exec_id.ml0000644000175000017500000000106113177364665016154 0ustar gerdgerd (* * A job identifier is just an integer. *) type t = int module IdTable = Lm_map.LmMake (struct type t = int let compare = (-) end) let pp_print_pid = Format.pp_print_int (* Id allocation. *) let null_id = 0 let index = ref 1 let create () = let id = !index in index := succ id; id (* * Marshaling. *) let marshal_id id : Lm_marshal.msg = List [Magic IdMagic; Int id] let unmarshal_id (l : Lm_marshal.msg) = match l with | List [Magic IdMagic; Int id] -> id | _ -> raise Lm_marshal.MarshalError omake-0.10.3/src/exec/omake_exec_local.ml0000644000175000017500000004515513177364666016667 0ustar gerdgerd(* Execute on the local machine. *) open Lm_printf open Omake_exec_type open Omake_command_type let buffer_len = 4096 (* default size of pipebufs (both Linux and Win32) *) let unix_close debug fd = if !Lm_thread_pool.debug_thread then eprintf "Closing: %s: %d@." debug (Lm_unix_util.int_of_fd fd); try Unix.close fd with Unix.Unix_error (errno, f, arg) as exn -> if !Lm_thread_pool.debug_thread then eprintf "%s: close failed: %s %s(%s)@." debug (Unix.error_message errno) f arg; raise exn type 'value job_state = |JobStarted | JobRunning of 'value | JobFinished of int * 'value * float type fd_state = | Fd_open | Fd_eof | Fd_eof_ack | Fd_closed (* * A job has channels for communication, * plus info. *) type ('exp, 'pid, 'value) job = { job_id : Omake_exec_id.t; job_target : Omake_node.Node.t; job_handle_out : Omake_exec_type.output_fun; job_handle_err : Omake_exec_type.output_fun; job_handle_status : ('exp, 'pid, 'value) Omake_exec_type.status_fun; job_start_time : float; (* Evaluator *) job_shell : ('exp, 'pid, 'value) Omake_exec_type.shell; (* State while a job is running *) mutable job_pid : 'pid; mutable job_stdout : Unix.file_descr; mutable job_stdout_done: fd_state; mutable job_stderr : Unix.file_descr; mutable job_stderr_done: fd_state; mutable job_state : 'value job_state; mutable job_print_flag : bool; (* The commnds to be run after the current command is done *) mutable job_command : 'exp; mutable job_commands : 'exp list; (* A temporary buffer for copying. *) job_buffer_len : int; job_buffer : bytes * bytes; } (* * The state: * server_jobs: currently running jobs *) type ('exp, 'pid, 'value) t = { mutable server_table : ('exp, 'pid, 'value) job Omake_exec_util.FdTable.t; mutable server_jobs : ('exp, 'pid, 'value) job list } let create _ = { server_table = Omake_exec_util.FdTable.empty; server_jobs = [] } (* * Printing. *) (* let pp_print_pid = pp_print_int *) let allow_output shell command = let flags, _dir, _target = shell.shell_info command in List.mem AllowOutputFlag flags (* * Print an error to the error channel. *) let handle_exn handle_err pp_print_exn id exn = let out = byte_formatter (handle_err id) ignore in fprintf out "@[ *** process creation failed:@ %a@]@." pp_print_exn exn (* * When the server is closed, kill all the jobs. *) let close server = Omake_exec_util.FdTable.iter (fun fd _ -> Unix.close fd) server.server_table; List.iter (fun { job_shell = shell; job_pid = pid; job_state = state ; _} -> match state with JobFinished _ -> () | JobStarted | JobRunning _ -> try shell.shell_kill pid with Unix.Unix_error _ | Invalid_argument _ -> ()) server.server_jobs (* * Find a finished job, or raise Not_found if there is none. *) let find_finished_job server = let rec find running_jobs = function { job_state = JobFinished (code, value, time) ; _} as job :: jobs -> job, code, value, List.rev_append running_jobs jobs, time | { job_state = JobStarted | JobRunning _ ; _} as job :: jobs -> find (job :: running_jobs) jobs | [] -> raise Not_found in find [] server.server_jobs (* * Start a command. Takes the output channels, and returns a pid. *) let start_command _server (shell : _ Omake_exec_type.shell) stdout stderr command = shell.shell_eval stdout stderr command let likely_blocking server = List.exists (fun job -> let shell = job.job_shell in let all_cmds = job.job_command :: job.job_commands in let non_nops = List.filter (fun cmd -> not(shell.shell_eval_is_nop cmd)) all_cmds in match non_nops with | cmd :: _ -> shell.shell_eval_is_cmd cmd | [] -> false ) server.server_jobs (* * Start a job. *) let rec spawn_exn server shell id handle_out handle_err handle_status target commands = let command, commands = match commands with command :: commands -> command, commands | [] -> raise (Invalid_argument "Omake_exec_local.spawn") in let { server_table = table; server_jobs = jobs } = server in if shell.shell_eval_is_nop command && commands <> [] then (* quickly skip over nop's *) spawn_exn server shell id handle_out handle_err handle_status target commands else Omake_exec_util.with_pipe (fun out_read out_write -> Omake_exec_util.with_pipe (fun err_read err_write -> if !Lm_thread_pool.debug_thread then begin eprintf "out_read: %d, out_write: %d@." (Lm_unix_util.int_of_fd out_read) (Lm_unix_util.int_of_fd out_write); eprintf "err_read: %d, err_write: %d@." (Lm_unix_util.int_of_fd err_read) (Lm_unix_util.int_of_fd err_write) end; let () = handle_status id (PrintEager command); Unix.set_close_on_exec out_read; Unix.set_close_on_exec err_read in let now = Unix.gettimeofday() in let pid = start_command server shell out_write err_write command in let job = { job_id = id; job_target = target; job_handle_out = handle_out; job_handle_err = handle_err; job_handle_status = handle_status; job_start_time = now; job_pid = pid; job_state = JobStarted; job_stdout = out_read; job_stdout_done = Fd_open; job_stderr = err_read; job_stderr_done = Fd_open; job_command = command; job_commands = commands; job_print_flag = false; job_shell = shell; job_buffer_len = buffer_len; job_buffer = Bytes.create buffer_len, Bytes.create buffer_len; } in let table = Omake_exec_util.FdTable.add table out_read job in let table = Omake_exec_util.FdTable.add table err_read job in if !Omake_exec_util.debug_exec then eprintf "Started job %d, stdout=%d, stderr=%d@." (**) (Obj.magic pid) (Lm_unix_util.int_of_fd out_read) (Lm_unix_util.int_of_fd err_read); unix_close "spawn_exn.1" out_write; unix_close "spawn_exn.2" err_write; server.server_table <- table; server.server_jobs <- job :: jobs; ProcessStarted id)) let err_print_status commands handle_status id = match commands with command :: _ -> handle_status id (PrintLazy command) | [] -> () let spawn server shell id handle_out handle_err handle_status target commands = try spawn_exn server shell id handle_out handle_err handle_status target commands with exn -> err_print_status commands handle_status id; handle_exn handle_err shell.shell_print_exn id exn; if shell.shell_is_failure_exn exn then ProcessFailed else raise exn (* * Start the next part of the job. *) let rec spawn_next_part_exn server job = let { job_id = id; job_shell = shell; job_target = _target; job_commands = commands; job_handle_out = handle_out; job_handle_err = handle_err; job_handle_status = handle_status; _ } = job in let { server_table = table ; _} = server in match commands with | command :: commands -> if shell.shell_eval_is_nop command then ( (* quickly skip over nop's *) job.job_commands <- commands; spawn_next_part_exn server job ) else Omake_exec_util.with_pipe (fun out_read out_write -> Omake_exec_util.with_pipe (fun err_read err_write -> let () = handle_status id (PrintEager command); Unix.set_close_on_exec out_read; Unix.set_close_on_exec err_read in let pid = start_command server shell out_write err_write command in let table = Omake_exec_util.FdTable.add table out_read job in let table = Omake_exec_util.FdTable.add table err_read job in if !Omake_exec_util.debug_exec then eprintf "Started next job %d, stdout=%d, stderr=%d@." (**) (Obj.magic pid) (Lm_unix_util.int_of_fd out_read) (Lm_unix_util.int_of_fd err_read); unix_close "spawn_next_part.1" out_write; unix_close "spawn_next_part.2" err_write; job.job_pid <- pid; job.job_stdout <- out_read; job.job_stdout_done <- Fd_open; job.job_stderr <- err_read; job.job_stderr_done <- Fd_open; job.job_command <- command; job.job_commands <- commands; job.job_print_flag <- false; server.server_table <- table)) | [] -> match job.job_state with JobRunning v -> (* Close output channels *) handle_out id (Bytes.create 0) 0 0; handle_err id (Bytes.create 0) 0 0; job.job_state <- JobFinished (0, v, Unix.gettimeofday() -. job.job_start_time) | JobStarted | JobFinished _ -> raise (Invalid_argument "spawn_next_part") let spawn_next_part server job = try spawn_next_part_exn server job with exn -> let shell = job.job_shell in err_print_status job.job_commands job.job_handle_status job.job_id; handle_exn job.job_handle_err shell.shell_print_exn job.job_id exn; job.job_state <- JobFinished (Omake_state.fork_error_code, shell.shell_error_value, Unix.gettimeofday() -. job.job_start_time); if not (shell.shell_is_failure_exn exn) then raise exn (* * Check if a command is an error. *) let command_code shell _options command status = let flags, _, _ = shell.shell_info command in let code = match status with Unix.WEXITED code -> code | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> Omake_state.signal_error_code in if code <> 0 && not (List.mem AllowFailureFlag flags) then code else 0 (* * Wait for the current part to finish. *) let wait_for_job server options job = let { job_pid = pid; job_command = command; job_shell = shell ; _} = job in let () = if !Omake_exec_util.debug_exec then eprintf "Waiting for job %d@." (Obj.magic pid) in let status, v = shell.shell_wait pid in let code = command_code shell options command status in if !Omake_exec_util.debug_exec then eprintf "Job exited with code %d@." code; if code <> 0 then job.job_state <- JobFinished (code, shell.shell_error_value, Unix.gettimeofday() -. job.job_start_time) else begin job.job_state <- JobRunning v; spawn_next_part server job end let acknowledge_eof server _options fd = let job = try Omake_exec_util.FdTable.find server.server_table fd with Not_found -> assert false in if job.job_stdout_done = Fd_eof && fd = job.job_stdout then ( if !Omake_exec_util.debug_exec then eprintf "Ack-eof stdout fd %d@." (Lm_unix_util.int_of_fd fd); job.job_stdout_done <- Fd_eof_ack; ) else if job.job_stderr_done = Fd_eof && fd = job.job_stderr then ( if !Omake_exec_util.debug_exec then eprintf "Ack-eof stderr fd %d@." (Lm_unix_util.int_of_fd fd); job.job_stderr_done <- Fd_eof_ack; ) (* When both states are Fd_eof_ack we know that both threads are done, and that we can reuse the job record for the next command *) let handle_eof server options fd = let job_opt = try Some (Omake_exec_util.FdTable.find server.server_table fd) with Not_found -> None in match job_opt with | None -> () | Some job -> let ack_stdout = job.job_stdout_done = Fd_eof_ack in let ack_stderr = job.job_stderr_done = Fd_eof_ack in (* When we close, another thread may get exactly the same fd for a newly opened file. Because of this, closing the fd must first happen when fd has been removed from all tables. *) if ack_stdout then ( let table = Omake_exec_util.FdTable.remove server.server_table job.job_stdout in server.server_table <- table; job.job_stdout_done <- Fd_closed; unix_close "handle_eof (stdout)" job.job_stdout; ); if ack_stderr then ( let table = Omake_exec_util.FdTable.remove server.server_table job.job_stderr in server.server_table <- table; job.job_stderr_done <- Fd_closed; unix_close "handle_eof (stderr)" job.job_stderr; ); if job.job_stdout_done = Fd_closed && job.job_stderr_done = Fd_closed then wait_for_job server options job let unix_read fd buf pos len = try Unix.read fd buf pos len with Unix.Unix_error _ -> 0 let rec unix_really_read fd buf pos len acc = let n = unix_read fd buf pos len in if n > 0 && n < len then unix_really_read fd buf (pos+n) (len-n) (acc+n) else acc let fd_closed = [ Fd_eof_ack; Fd_closed ] (* states that must not occur at the beginning of [handle] *) (* * Handle data on a channel. (This function may be called from a thread.) *) let handle_1 server _options fd = let job = try Omake_exec_util.FdTable.find server.server_table fd with Not_found -> raise (Invalid_argument "Omake_exec.handle_channel: no such job") in let { job_id = id; job_stdout = stdout; job_stdout_done = stdout_done; job_stderr = stderr; job_stderr_done = stderr_done; job_handle_out = handle_out; job_handle_err = handle_err; job_handle_status = handle_status; job_command = command; job_buffer_len = buffer_len; job_buffer = buffer_stdout, buffer_stderr; _ } = job in let handle_data, buffer, is_closed = if fd = stdout then handle_out, buffer_stdout, List.mem stdout_done fd_closed else if fd = stderr then handle_err, buffer_stderr, List.mem stderr_done fd_closed else raise (Invalid_argument "Omake_exec.handle_channel: unknown file descriptor") in if is_closed then raise (Invalid_argument "Omake_exec.handle_channel: trying to read from closed file descriptor"); (* Read from the descriptor. *) let count, eof = let n = unix_read fd buffer 0 buffer_len in n, n=0 in if count > 0 then begin (* For "AllowOutputFlag" commands (e.g. scanner) stdout does not "count", but stderr still does *) if not (job.job_print_flag || (fd = stdout && allow_output job.job_shell command)) then begin handle_status id (PrintLazy command); job.job_print_flag <- true end; handle_data id buffer 0 count; end; (* Handle end of file *) if eof then begin (* NB. handle_eof (above) may be running concurrently, and will immediately detect when job_std{out,err}_done is changed. *) if fd = stdout then ( if !Omake_exec_util.debug_exec then eprintf "stdout EOF fd %d@." (Lm_unix_util.int_of_fd fd); job.job_stdout_done <- Fd_eof ) else ( if !Omake_exec_util.debug_exec then eprintf "stderr EOF fd %d@." (Lm_unix_util.int_of_fd fd); job.job_stderr_done <- Fd_eof; ); true (* indicate eof to caller *) end else false let handle server options fd = (* We run the whole handler outside the Lm_thread_pool lock (which is safe as the handlers only write to files, see omake_exec_util) *) Lm_thread_pool.blocking_section (fun () -> handle_1 server options fd) () (* * Get all the descriptors. *) let descriptors server = Omake_exec_util.FdTable.fold (fun fd_set fd _ -> if !Lm_thread_pool.debug_thread then eprintf "Local.descriptors: %d@." (Lm_unix_util.int_of_fd fd); fd :: fd_set) [] server.server_table (* * The wait process handles output from each of the jobs. * Once both output channels are closed, the job is finished. *) let wait server _options = try let job, code, value, jobs, time = find_finished_job server in let { job_id = id; job_handle_status = handle_status; job_command = command; _ } = job in server.server_jobs <- jobs; handle_status id (PrintExit (command, code, value, time)); WaitInternalExited (id, code, value) with Not_found -> WaitInternalNone omake-0.10.3/src/exec/omake_exec_print.ml0000644000175000017500000001460413177364666016724 0ustar gerdgerd(* * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2003-2006 Mojave Group, Caltech * * 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; version 2 * of the License. * * 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, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * * Additional permission is given to link this library with the * with the Objective Caml runtime, and to redistribute the * linked executables. See the file LICENSE.OMake for more details. * * Author: Jason Hickey @email{jyh@cs.caltech.edu} * Modified By: Aleksey Nogin @email{nogin@metaprl.org} * @end[license] *) open! Lm_printf open Omake_node open Omake_state open Omake_exec_type open Omake_options open Omake_command_type (* * When the progress bar is printed, it leaves the line with text on it. * Remember if this text should be deleted. *) let progress_flush_flag = ref false let progress_flushed_flag = ref false (* * Print the progress bar. *) let message = ref None let message_timeout = ref 0.0 let progress_width = Lm_termsize.stdout_width - 20 let print_progress options count total = if opt_print_progress options then let blobs = count * progress_width / total in let () = print_char '[' in let off = match !message with Some s -> (* The message has a finite lifetime *) if Unix.gettimeofday () >= !message_timeout then message := None; (* Print the message first *) print_string s; print_char ' '; String.length s + 1 | None -> 0 in for _i = off to blobs do print_char '=' done; for _i = 0 to progress_width - max off blobs do print_char ' ' done; printf "] %05d / %05d\r@?" count total; progress_flush_flag := true; progress_flushed_flag := false (* * Flush the print line if needed. *) let flush_buf = String.make (Lm_termsize.stdout_width - 1) ' ' let progress_flush () = if !progress_flush_flag then begin printf "%s\r@?" flush_buf; progress_flush_flag := false; progress_flushed_flag := true end let progress_flushed () = !progress_flushed_flag (* * Print a short message. * XXX: Should the message_timeout delay be an option? *) let print_message options s = if opt_print_progress options then begin message := Some s; message_timeout := Unix.gettimeofday () +. 3.0 end else printf "*** omake: %s@." s (* * Print a message saying that the cache is being saved. *) let saving_message = "saved " ^ db_name let print_saving options = if opt_print_status options then print_message options saving_message (* * Print the current directory. * Keep track of the directory, to minimize spamming * of the omake output. *) let current_dir = ref None let print_entering_current_directory options dir = if opt_print_dir options then match !current_dir with Some cwd -> if not (Dir.equal dir cwd) then begin printf "make[1]: Leaving directory `%s'@." (Dir.absname cwd); current_dir := Some dir; printf "make[1]: Entering directory `%s'@." (Dir.absname dir) end | None -> current_dir := Some dir; printf "make[1]: Entering directory `%s'@." (Dir.absname dir) let print_leaving_current_directory options = if opt_print_dir options then match !current_dir with Some cwd -> printf "make[1]: Leaving directory `%s'@." (Dir.absname cwd); current_dir := None | None -> () (* * Print a status line. *) let should_print options flag = match flag, opt_print_command options with PrintEager _, EvalEager | PrintLazy _, EvalLazy -> true | PrintExit _, _ -> opt_print_exit options | _ -> false let print_status handle_out options shell remote name flag = let print_flush () = handle_out (Bytes.create 0) 0 0 in let out = byte_formatter handle_out print_flush in let pp_print_host buf = match remote with Some host -> fprintf buf "[%s]" host | None -> () in match flag with PrintEager exp | PrintLazy exp -> let flags, dir, target = shell.shell_info exp in if should_print options flag then let dirname = Dir.fullname dir in print_flush (); print_entering_current_directory options dir; if opt_print_file options then fprintf out "-%t %s %s %s@." pp_print_host name dirname (Node.name dir target); if not (List.mem QuietFlag flags) then fprintf out "+%t %a@." pp_print_host shell.shell_print_exp exp | PrintExit (exp, code, _, time) -> let _flags, dir, target = shell.shell_info exp in let dirname = Dir.fullname dir in if should_print options flag && opt_print_file options then begin print_flush (); fprintf out "-%t exit %s %s, %a, code %d@." pp_print_host dirname (Node.name dir target) Lm_unix_util.pp_time time code end (* * Print a list of lines. *) let pp_status_lines out _options shell name el = (* Print the commands *) let first = ref true in fprintf out " @["; List.iter (fun exp -> let _flags, dir, target = shell.shell_info exp in if !first then begin fprintf out "- %s %s %s" name (Dir.fullname dir) (Node.name dir target); first := false; end; fprintf out "@ + %a" shell.shell_print_exp exp) el; fprintf out " @]@." (* * -*- * Local Variables: * End: * -*- *) omake-0.10.3/src/exec/omake_exec_local.mli0000644000175000017500000000020213177364666017020 0ustar gerdgerd(* Utilities for program execution. *) include Omake_exec_type.ExecServer val likely_blocking : ('exp, 'pid, 'value) t -> bool omake-0.10.3/src/exec/omake_exec_print.mli0000644000175000017500000000474413177364666017101 0ustar gerdgerd(* * Status printing. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2003-2006 Mojave Group, Caltech * * 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; version 2 * of the License. * * 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, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * * Additional permission is given to link this library with the * with the Objective Caml runtime, and to redistribute the * linked executables. See the file LICENSE.OMake for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) open Lm_printf open Omake_node open Omake_exec_type (* * Flush the progress meter. *) val progress_flush : unit -> unit val progress_flushed : unit -> bool (* * Print a progress indicator. *) val print_progress : Omake_options.t -> int -> int -> unit (* * Saving the cache messages. *) val print_saving : Omake_options.t -> unit (* * Directory changes. *) val print_entering_current_directory : Omake_options.t -> Dir.t -> unit val print_leaving_current_directory : Omake_options.t -> unit (* * Print a status line. *) val print_status : (bytes -> int -> int -> unit) -> (* Diversion *) Omake_options.t -> (* Options currently in effect *) ('exp, 'pid, 'value) shell -> (* The context *) string option -> (* Remote host name *) string -> (* Name of operation being performed *) ('exp, 'pid, 'value) print_flag -> (* What to print *) unit (* * Print a status lines. *) val pp_status_lines : formatter -> (* Output channel *) Omake_options.t -> (* Options currently in effect *) ('exp, 'pid, 'value) shell -> (* The current shell *) string -> (* Name of operation being performed *) 'exp list -> (* What to print *) unit (* * -*- * Local Variables: * End: * -*- *) omake-0.10.3/src/exec/omake_exec.mli0000644000175000017500000000236613177364666015663 0ustar gerdgerd(* * Utilities for program execution. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2003 Jason Hickey, Caltech * * 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; version 2 * of the License. * * 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, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * * Additional permission is given to link this library with the * with the Objective Caml runtime, and to redistribute the * linked executables. See the file LICENSE.OMake for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) open Omake_exec_type module Exec : ExecService (*! * @docoff * * -*- * Local Variables: * Caml-master: "compile" * End: * -*- *) omake-0.10.3/src/exec/omake_exec_notify.mli0000644000175000017500000000317213177364666017247 0ustar gerdgerd(* * File change notifications. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2003 Jason Hickey, Caltech * * 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; version 2 * of the License. * * 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, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * * Additional permission is given to link this library with the * with the Objective Caml runtime, and to redistribute the * linked executables. See the file LICENSE.OMake for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) open Omake_node open Omake_exec_type (* * Local server. *) module Notify : sig include ExecServer (* * Watch a node for changes. *) val monitor : ('exp, 'pid, 'value) t -> Node.t -> unit val monitor_tree : ('exp, 'pid, 'value) t -> Dir.t -> unit (* * Get the next notification event. *) val pending : ('exp, 'pid, 'value) t -> bool val next_event : ('exp, 'pid, 'value) t -> Lm_notify.event end (*! * @docoff * * -*- * Local Variables: * Caml-master: "compile" * End: * -*- *) omake-0.10.3/src/exec/omake_exec_remote.mli0000644000175000017500000000043713177364666017233 0ustar gerdgerd(* Utilities for program execution. *) val debug_remote : bool ref (* The main function, if invoked on a remote machine. *) val main : ('exp, 'pid, 'value) Omake_exec_type.shell -> Omake_options.t -> unit (* The interface to the remote server. *) include Omake_exec_type.ExecServer omake-0.10.3/src/exec/omake_exec_util.mli0000644000175000017500000000160513177364666016713 0ustar gerdgerd(* * Utilities for process execution on any platform. * *) (* * Debugging. *) val debug_exec : bool ref (* * File descriptor table. *) module IntTable : Lm_map_sig.LmMap with type key = int;; module FdTable : Lm_map_sig.LmMap with type key = Unix.file_descr;; (* * Open a pipe. Close automatically on exceptions. *) val with_pipe : (Unix.file_descr -> Unix.file_descr -> 'a) -> 'a (* * Copy data to a file. *) val copy_file : string -> (Omake_exec_id.t -> bytes -> int -> int -> unit) (* * Tee to a file. *) type tee val tee_none : tee val tee_create : bool -> tee val tee_close : tee -> unit val tee_file : tee -> string option val tee_stdout : tee -> bool -> Omake_exec_id.t -> bytes -> int -> int -> unit val tee_stderr : tee -> bool -> Omake_exec_id.t -> bytes -> int -> int -> unit val tee_file_descr : tee -> Unix.file_descr option omake-0.10.3/src/exec/omake_exec_id.mli0000644000175000017500000000047013177364666016331 0ustar gerdgerd(* Type of job identifiers. *) type t module IdTable : Lm_map_sig.LmMap with type key = t (* "Null" id for the "master" process. *) val null_id : t (* Get a new id. *) val create : unit -> t val pp_print_pid : t Lm_printf.t val marshal_id : t -> Lm_marshal.msg val unmarshal_id : Lm_marshal.msg -> t omake-0.10.3/src/env/0000755000175000017500000000000013177364666012715 5ustar gerdgerdomake-0.10.3/src/env/OMakefile0000644000175000017500000000322713177364665014477 0ustar gerdgerdOCAMLINCLUDES[] += ../libmojave ../exec ../magic ../ast ../ir FILES[] = omake_env omake_exn_print omake_ast_parse omake_ast_lex omake_exp_parse omake_exp_lex omake_ir_ast omake_ir_semant omake_command_digest # omake_env_util # # The yacc parser file is generated # GENPARSE = omake_gen_parse .SCANNER: scan-ocaml-omake_gen_parse.ml: MakeOCamlProgram($(GENPARSE), $(GENPARSE)) $(GENPARSE)$(EXE): # # All generated files # GENERATED_FILES[] = omake_ast_lex.ml omake_ast_parse.mly omake_ast_parse.mli omake_ast_parse.ml omake_exp_parse.ml omake_exp_parse.mli LocalOCamlGeneratedFiles($(GENERATED_FILES)) omake_ast_parse.mly: $(GENPARSE)$(EXE) omake_ast_parse.input ./$(GENPARSE) -o $@ omake_ast_parse.input clean: $(CLEAN) $(GENERATED_FILES) $(GENPARSE)$(EXE) $(GENPARSE).opt $(GENPARSE).run # # The final library # MakeOCamlLibrary(env, $(FILES)) ######################################################################## # Generate the Makefile # MAKEFILE_TEXT += $""" GENPARSE = $(GENPARSE) omake_ast_parse.mly: $$(GENPARSE)$$(EXE) omake_ast_parse.input $$(DOT)$$(GENPARSE) -o $$@ omake_ast_parse.input omake_ast_lex.ml: omake_ast_lex.mll omake_ast_lex.cmo: omake_ast_lex.cmi omake_ast_parse.ml: omake_ast_parse.mly omake_ast_parse.mli: omake_ast_parse.mly omake_ast_parse.cmo: omake_ast_parse.cmi omake_exp_parse.ml: omake_exp_parse.mly omake_exp_parse.mli: omake_exp_parse.mly omake_exp_parse.cmo: omake_exp_parse.cmi """ MakeLinkFiles(omake_ast_lex.mll omake_ast_parse.input omake_exp_parse.mly) MakeDontLink($(GENERATED_FILES)) MakeOCamlDepend($(FILES), magic.cma) MakeMakefile() omake-0.10.3/src/env/omake_gen_parse.ml0000644000175000017500000001251613177364665016372 0ustar gerdgerd(* * Bah, autogenerate the parse tables. *) open Printf (************************************************************************ * Tokens and their productions. *) let tokens = ["TokWhite", "StringWhiteExp"; "TokOp", "StringOpExp"; "TokLeftParen", "StringOpExp"; "TokRightParen", "StringOpExp"; "TokArrow", "StringOpExp"; "TokComma", "StringOpExp"; "TokColon", "StringOpExp"; "TokDoubleColon", "StringOpExp"; "TokNamedColon", "StringOpExp"; "TokEq", "StringOpExp"; "TokArray", "StringOpExp"; "TokDot", "StringOpExp"; "TokId", "StringIdExp"; "TokInt", "StringIntExp"; "TokFloat", "StringFloatExp"; "TokKey", "StringKeywordExp"; "TokKeyword", "StringKeywordExp"; "TokCatch", "StringKeywordExp"; "TokClass", "StringKeywordExp"; "TokString", "StringOtherExp"] let named_tokens = ["quote", "{ $1 }"; "apply", "{ $1 }"] let tokens = let print_const name = sprintf "{ let (s, loc) = $1 in %s (s, loc), loc }" name in let tokens = List.map (fun (s, id) -> s, print_const id) tokens in tokens @ named_tokens (************************************************************************ * Sets of tokens. *) let colon = ["TokColon"; "TokDoubleColon"; "TokNamedColon"] let id = ["TokId"; "TokKeyword"; "TokCatch"; "TokClass"] let key = ["TokId"; "TokKeyword"; "TokCatch"; "TokClass"; "TokKey"] let white = ["TokWhite"] let parens = ["TokLeftParen"; "TokRightParen"] let arg = ["TokComma"; "TokArrow"; "TokIn"] (************************************************************************ * Productions. *) let subtract l1 l2 = List.fold_left (fun l1 v -> List.remove_assoc v l1) l1 l2 let add l1 l2 = List.fold_left (fun l v -> (v, List.assoc v l1) :: l) [] l2 let text_next = tokens let text_nonwhite = subtract tokens white let target_next = subtract tokens colon let target_start = subtract target_next white let keyword_target_start = subtract target_start ["TokLeftParen"] let paren_next = subtract tokens parens let arg_next = subtract paren_next arg let arg_any_start = subtract arg_next white let arg_start = subtract arg_any_start key let arg_next_noneq = subtract arg_any_start ["TokEq"] let other_start = subtract tokens ("TokWhite" :: "quote" :: List.flatten [id; colon]) let other_method_id_white = subtract tokens ("TokEq" :: "TokArray" :: "TokLeftParen" :: "TokColon" :: colon) let other_method_id = subtract other_method_id_white ("TokDot" :: white) let other_method_id_prefix_white = subtract tokens ("TokEq" :: List.flatten [id; colon]) let other_method_id_prefix = subtract other_method_id_prefix_white white let other_quote_id_white = subtract tokens ("TokEq" :: "TokColon" :: colon) let other_quote_id = subtract other_quote_id_white white let productions = ["colon", add tokens colon; "white", add tokens white; "text_next", text_next; "text_nonwhite", text_nonwhite; "target_next", target_next; "target_start", target_start; "keyword_target_start", keyword_target_start; "paren_next", paren_next; "arg_next", arg_next; "arg_start", arg_start; "arg_any_start", arg_any_start; "arg_next_noneq", arg_next_noneq; "other_start", other_start; "other_method_id_white", other_method_id_white; "other_method_id", other_method_id; "other_method_id_prefix_white", other_method_id_prefix_white; "other_method_id_prefix", other_method_id_prefix; "other_quote_id_white", other_quote_id_white; "other_quote_id", other_quote_id] let print_productions outx = List.iter (fun (v, tokens) -> fprintf outx "%s:\n" v; List.iter (fun (v, body) -> fprintf outx "\t| %s\n\t\t%s\n" v body) tokens; fprintf outx "\t;\n") productions (************************************************************************ * Process the input file, and write the output file. *) let copy inx outx = let rec copy_exn () = let line = input_line inx in let line = let l = String.length line in if l > 0 then let l = l - 1 in match line.[l] with '\n' | '\r' -> String.sub line 0 l | _ -> line else line in if line = "%%GENERATED%%" then print_productions outx else fprintf outx "%s\n" line; copy_exn () in let () = try copy_exn () with End_of_file -> () in close_in inx; close_out outx let infile = ref None let outfile = ref None let spec = ["-o", Arg.String (fun s -> outfile := Some s), "set output file"] let usage = "Generate parse file" let set_input s = infile := Some s let main () = Arg.parse spec set_input usage; let inx = match !infile with | Some file -> open_in file | None -> stdin in let outx = match !outfile with | Some file -> open_out file | None -> stdout in copy inx outx let () = Printexc.catch main () omake-0.10.3/src/env/omake_ast_parse.ml0000644000175000017500000056341613177364665016422 0ustar gerdgerdtype token = | TokEof of (Lm_location.t) | TokEol of (Lm_location.t) | TokWhite of (string * Lm_location.t) | TokLeftParen of (string * Lm_location.t) | TokRightParen of (string * Lm_location.t) | TokArrow of (string * Lm_location.t) | TokComma of (string * Lm_location.t) | TokColon of (string * Lm_location.t) | TokDoubleColon of (string * Lm_location.t) | TokNamedColon of (string * Lm_location.t) | TokDollar of (string * Omake_ast.apply_strategy * Lm_location.t) | TokEq of (string * Lm_location.t) | TokArray of (string * Lm_location.t) | TokDot of (string * Lm_location.t) | TokId of (string * Lm_location.t) | TokKey of (string * Lm_location.t) | TokKeyword of (string * Lm_location.t) | TokCatch of (string * Lm_location.t) | TokClass of (string * Lm_location.t) | TokOp of (string * Lm_location.t) | TokInt of (string * Lm_location.t) | TokFloat of (string * Lm_location.t) | TokString of (string * Lm_location.t) | TokBeginQuote of (string * Lm_location.t) | TokEndQuote of (string * Lm_location.t) | TokBeginQuoteString of (string * Lm_location.t) | TokEndQuoteString of (string * Lm_location.t) | TokStringQuote of (string * Lm_location.t) | TokVar of (Omake_ast.apply_strategy * string * Lm_location.t) | TokVarQuote of (Omake_ast.apply_strategy * string * Lm_location.t) open Parsing;; let _ = parse_error;; # 3 "omake_ast_parse.mly" include Omake_pos.Make (struct let name = "Omake_parse" end) (* * Define flags. *) let define_flag (s, loc) = match s with | "=" -> Omake_ast.DefineNormal | "+=" -> DefineAppend | _ -> raise (Omake_value_type.OmakeException (loc_exp_pos loc, StringStringError ("undefined assignment operator", s))) (* * Convert arguments to parameters. *) let key_of_id s = Lm_symbol.add (String.sub s 1 (String.length s - 1)) let parse_id_param s loc = match s.[0] with '?' -> Omake_ast.OptionalParam (key_of_id s, NullExp loc, loc) | '~' -> RequiredParam (key_of_id s, loc) | _ -> NormalParam (Lm_symbol.add s, loc) let param_of_arg arg = match arg with | Omake_ast.IdArg (s, _, loc) -> parse_id_param s loc | NormalArg (KeyArg (v, e)) -> OptionalParam (v, e, Omake_ast_util.loc_of_exp e) | NormalArg (ExpArg e) -> raise (Omake_value_type.OmakeException (loc_exp_pos (Omake_ast_util.loc_of_exp e), StringAstError ("illegal function parameter", e))) | NormalArg (ArrowArg (_, e)) -> raise (Omake_value_type.OmakeException (loc_exp_pos (Omake_ast_util.loc_of_exp e), StringAstError ("illegal function argument", e))) let get_fun_params args = List.map param_of_arg args (* * Remove the IdArg. *) let arg_of_parse_arg = function | Omake_ast.IdArg (s, w, loc1) -> let id = Omake_ast.StringIdExp (s, loc1) in let e = match w with Some (w, loc2) -> Omake_ast.SequenceExp ([id; StringWhiteExp (w, loc2)], loc1) | None -> id in Omake_ast.ExpArg e | NormalArg arg -> arg let args_of_parse_args = List.map arg_of_parse_arg (* * Utilities. *) let rec simplify e = match e with | Omake_ast.SequenceExp ([e], _) -> simplify e | _ -> e let sequence_exp l loc = match l with | [e] -> e | _ -> Omake_ast.SequenceExp (l, loc) (* * Intern the method name. *) let method_id_intern idl = List.map Lm_symbol.add idl (* * Get a string from a method name. *) let method_id_string idl = let buf = Buffer.create 32 in let rec collect idl = match idl with [id] -> Buffer.add_string buf id | id :: idl -> Buffer.add_string buf id; Buffer.add_char buf '.'; collect idl | [] -> () in collect idl; Buffer.contents buf let rec method_id_rev_sequence loc items idl = match idl with [id] -> (Omake_ast.StringIdExp (id, loc)) :: items | id :: idl -> let items = Omake_ast.StringOpExp (".", loc) :: StringIdExp (id, loc) :: items in method_id_rev_sequence loc items idl | [] -> items let method_id_sequence loc idl = List.rev (method_id_rev_sequence loc [] idl) let method_id_string_exp idl loc = Omake_ast.SequenceExp (method_id_sequence loc idl, loc) let method_id_prefix_string_exp idl loc = let idl = List.rev (method_id_rev_sequence loc [StringOpExp (".", loc)] idl) in Omake_ast.SequenceExp (idl, loc) let var_quote (strategy, s, loc) = Omake_ast.KeyExp (strategy, s, loc), loc (* * Convert to a body flag and text. *) let get_optcolon_text opt loc = match opt with None -> Omake_ast.OptBody, Omake_ast.NullExp loc | Some (body, arg) -> body, arg (* * A 3-place rule. *) let rule3 multiple (target, loc1) _ pattern source loc2 body = let loc = Lm_location.union_loc loc1 loc2 in match pattern with Some (pattern, _) -> Omake_ast.RuleExp (multiple, target, pattern, source, body, loc) | None -> RuleExp (multiple, target, NullExp loc2, source, body, loc) let rule2 multiple target ploc source loc2 body = rule3 multiple target ploc None source loc2 body # 182 "omake_ast_parse.ml" let yytransl_const = [| 0|] let yytransl_block = [| 257 (* TokEof *); 258 (* TokEol *); 259 (* TokWhite *); 260 (* TokLeftParen *); 261 (* TokRightParen *); 262 (* TokArrow *); 263 (* TokComma *); 264 (* TokColon *); 265 (* TokDoubleColon *); 266 (* TokNamedColon *); 267 (* TokDollar *); 268 (* TokEq *); 269 (* TokArray *); 270 (* TokDot *); 271 (* TokId *); 272 (* TokKey *); 273 (* TokKeyword *); 274 (* TokCatch *); 275 (* TokClass *); 276 (* TokOp *); 277 (* TokInt *); 278 (* TokFloat *); 279 (* TokString *); 280 (* TokBeginQuote *); 281 (* TokEndQuote *); 282 (* TokBeginQuoteString *); 283 (* TokEndQuoteString *); 284 (* TokStringQuote *); 285 (* TokVar *); 286 (* TokVarQuote *); 0|] let yylhs = "\255\255\ \003\000\003\000\002\000\002\000\005\000\005\000\005\000\005\000\ \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ \005\000\005\000\005\000\005\000\005\000\005\000\005\000\001\000\ \021\000\021\000\021\000\022\000\023\000\023\000\023\000\023\000\ \023\000\023\000\015\000\015\000\029\000\028\000\030\000\031\000\ \032\000\024\000\033\000\033\000\026\000\026\000\026\000\026\000\ \011\000\011\000\011\000\016\000\016\000\016\000\012\000\012\000\ \013\000\013\000\036\000\038\000\035\000\035\000\037\000\037\000\ \037\000\037\000\019\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\017\000\017\000\020\000\020\000\048\000\ \048\000\048\000\004\000\027\000\027\000\018\000\018\000\050\000\ \050\000\007\000\007\000\052\000\052\000\052\000\052\000\052\000\ \014\000\055\000\055\000\009\000\009\000\025\000\025\000\057\000\ \057\000\057\000\059\000\059\000\060\000\058\000\058\000\062\000\ \063\000\063\000\063\000\063\000\063\000\065\000\066\000\061\000\ \061\000\064\000\064\000\064\000\064\000\067\000\067\000\069\000\ \069\000\070\000\070\000\068\000\068\000\072\000\076\000\076\000\ \076\000\054\000\054\000\054\000\034\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\008\000\008\000\010\000\010\000\006\000\006\000\ \000\000\000\000\000\000" let yylen = "\002\000\ \001\000\003\000\001\000\002\000\002\000\004\000\003\000\007\000\ \011\000\003\000\004\000\004\000\005\000\004\000\005\000\006\000\ \007\000\006\000\008\000\008\000\004\000\006\000\004\000\004\000\ \006\000\006\000\005\000\004\000\009\000\002\000\002\000\002\000\ \000\000\002\000\002\000\004\000\007\000\009\000\001\000\003\000\ \003\000\001\000\001\000\001\000\002\000\001\000\001\000\001\000\ \001\000\001\000\001\000\003\000\001\000\001\000\001\000\001\000\ \000\000\002\000\002\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\002\000\002\000\001\000\002\000\002\000\002\000\ \002\000\002\000\001\000\001\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\001\000\003\000\001\000\003\000\000\000\ \001\000\001\000\001\000\000\000\002\000\001\000\002\000\001\000\ \002\000\000\000\001\000\001\000\001\000\002\000\002\000\002\000\ \001\000\001\000\002\000\001\000\001\000\001\000\002\000\001\000\ \001\000\003\000\001\000\003\000\004\000\001\000\003\000\002\000\ \001\000\001\000\001\000\003\000\004\000\002\000\002\000\001\000\ \002\000\002\000\002\000\001\000\002\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\003\000\000\000\002\000\ \002\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ \001\000\001\000\000\000\002\000\001\000\003\000\000\000\001\000\ \002\000\002\000\002\000" let yydefred = "\000\000\ \033\000\000\000\000\000\000\000\185\001\000\000\003\000\184\001\ \075\001\076\001\077\001\078\001\000\000\079\001\080\001\081\001\ \069\000\084\001\000\000\000\000\000\000\074\001\082\001\083\001\ \085\001\092\000\092\000\042\000\039\000\046\000\186\001\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\086\001\000\000\ \000\000\062\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\076\000\001\000\187\001\000\000\000\000\032\000\035\000\ \000\000\000\000\034\000\000\000\000\000\148\000\147\000\146\000\ \072\000\000\000\000\000\000\000\074\000\000\000\073\000\000\000\ \000\000\000\000\004\000\005\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\030\000\000\000\031\000\000\000\000\000\ \045\000\144\001\146\001\147\001\148\001\149\001\150\001\151\001\ \152\001\155\001\156\001\157\001\158\001\145\001\153\001\154\001\ \159\001\161\001\049\000\160\001\082\000\163\001\164\001\165\001\ \166\001\167\001\168\001\169\001\172\001\173\001\174\001\175\001\ \162\001\170\001\171\001\176\001\178\001\177\001\081\000\067\000\ \104\001\105\001\106\001\071\000\107\001\110\001\111\001\112\001\ \113\001\103\001\108\001\109\001\114\001\116\001\115\001\077\000\ \087\001\089\001\090\001\091\001\092\001\093\001\096\001\097\001\ \098\001\099\001\088\001\094\001\095\001\100\001\102\001\101\001\ \078\000\068\000\132\001\133\001\134\001\135\001\136\001\137\001\ \053\000\140\001\054\000\055\000\056\000\131\001\138\001\139\001\ \141\001\143\001\070\000\142\001\079\000\117\001\119\001\120\001\ \121\001\122\001\123\001\124\001\127\001\118\001\125\001\126\001\ \128\001\130\001\129\001\080\000\193\000\195\000\196\000\197\000\ \198\000\199\000\200\000\201\000\202\000\205\000\206\000\207\000\ \208\000\194\000\203\000\204\000\209\000\211\000\210\000\083\000\ \000\000\150\000\152\000\153\000\154\000\155\000\156\000\157\000\ \158\000\159\000\160\000\161\000\162\000\165\000\166\000\167\000\ \168\000\151\000\163\000\164\000\169\000\171\000\170\000\093\000\ \213\000\214\000\215\000\216\000\217\000\218\000\219\000\220\000\ \223\000\224\000\225\000\226\000\212\000\221\000\222\000\227\000\ \229\000\228\000\000\000\096\000\000\000\000\000\231\000\232\000\ \233\000\234\000\235\000\236\000\237\000\240\000\241\000\242\000\ \243\000\230\000\238\000\239\000\244\000\000\000\246\000\245\000\ \000\000\100\000\101\000\000\000\007\000\180\001\000\000\010\000\ \149\000\059\000\058\000\040\000\041\000\000\000\000\000\109\000\ \000\000\000\000\115\000\118\000\000\000\000\000\000\000\000\000\ \084\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\002\000\097\000\000\000\000\000\006\000\102\000\103\000\ \104\000\000\000\000\000\143\000\030\001\031\001\032\001\033\001\ \034\001\035\001\000\000\029\001\036\001\037\001\038\001\040\001\ \000\000\039\001\120\000\000\000\000\000\000\000\132\000\139\000\ \138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\061\000\047\000\089\000\090\000\000\000\086\000\011\000\ \173\000\174\000\175\000\176\000\177\000\178\000\179\000\180\000\ \181\000\182\000\183\000\186\000\187\000\188\000\189\000\172\000\ \184\000\185\000\190\000\000\000\192\000\191\000\000\000\106\000\ \000\000\028\000\000\000\012\000\014\000\000\000\021\000\000\000\ \023\000\000\000\024\000\000\000\036\000\000\000\000\000\000\000\ \000\000\000\000\000\000\127\000\126\000\011\001\013\001\014\001\ \015\001\016\001\017\001\018\001\019\001\022\001\023\001\024\001\ \025\001\012\001\020\001\021\001\026\001\028\001\027\001\133\000\ \141\000\140\000\042\001\043\001\044\001\045\001\046\001\047\001\ \048\001\051\001\052\001\053\001\054\001\041\001\049\001\050\001\ \055\001\057\001\056\001\131\000\134\000\135\000\059\001\060\001\ \061\001\000\000\062\001\063\001\064\001\067\001\068\001\069\001\ \070\001\058\001\065\001\066\001\071\001\073\001\072\001\130\000\ \137\000\136\000\000\000\000\000\000\000\000\000\119\000\000\000\ \116\000\000\000\027\000\000\000\013\000\107\000\000\000\085\000\ \015\000\000\000\000\000\000\000\000\000\110\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\247\000\142\000\249\000\ \250\000\251\000\252\000\253\000\254\000\255\000\000\001\001\001\ \004\001\005\001\006\001\007\001\248\000\002\001\003\001\008\001\ \010\001\009\001\145\000\144\000\000\000\000\000\000\000\018\000\ \000\000\000\000\128\000\000\000\087\000\016\000\000\000\022\000\ \025\000\026\000\037\000\111\000\000\000\052\000\008\000\000\000\ \000\000\000\000\182\001\000\000\129\000\000\000\017\000\000\000\ \000\000\020\000\019\000\000\000\038\000\000\000\029\000\000\000\ \009\000" let yydgoto = "\004\000\ \005\000\031\000\052\000\053\000\032\000\057\000\022\001\067\000\ \039\001\212\001\072\000\034\000\035\000\124\001\036\000\037\000\ \048\001\049\001\038\000\102\001\006\000\059\000\238\000\142\001\ \231\001\081\001\054\000\107\000\041\000\042\000\043\000\239\000\ \144\001\232\001\045\000\046\000\047\000\048\000\049\000\050\000\ \144\000\161\000\181\000\196\000\127\000\109\000\216\000\103\001\ \240\000\003\001\004\001\025\001\026\001\007\002\127\001\128\001\ \040\001\041\001\042\001\043\001\010\002\044\001\083\001\084\001\ \085\001\086\001\011\002\029\002\208\001\087\001\189\001\169\001\ \210\001\089\001\170\001\147\001\004\002" let yysindex = "\146\001\ \000\000\153\255\041\255\000\000\000\000\013\001\000\000\000\000\ \000\000\000\000\000\000\000\000\046\255\000\000\000\000\000\000\ \000\000\000\000\105\000\059\255\044\255\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\067\255\ \146\255\129\000\113\000\111\255\144\255\043\000\000\000\159\255\ \000\000\000\000\121\255\177\003\178\002\206\002\203\255\014\000\ \122\002\000\000\000\000\000\000\211\255\010\002\000\000\000\000\ \031\003\197\255\000\000\208\255\203\003\000\000\000\000\000\000\ \000\000\035\000\228\255\046\255\000\000\001\000\000\000\183\255\ \156\000\238\001\000\000\000\000\046\255\046\255\046\255\046\255\ \046\255\046\255\046\255\000\000\046\255\000\000\046\255\046\255\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \040\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\122\002\000\000\046\255\046\255\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\048\000\000\000\000\000\ \038\002\000\000\000\000\046\255\000\000\000\000\046\255\000\000\ \000\000\000\000\000\000\000\000\000\000\054\003\050\000\000\000\ \009\255\062\000\000\000\000\000\081\003\233\255\045\000\151\255\ \000\000\065\000\036\001\194\255\063\000\201\255\075\000\012\000\ \092\000\000\000\000\000\109\000\067\000\000\000\000\000\000\000\ \000\000\111\000\117\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\046\255\000\000\000\000\000\000\000\000\000\000\ \046\255\000\000\000\000\150\002\104\003\127\003\000\000\000\000\ \000\000\046\255\046\255\046\255\046\255\112\000\136\000\044\255\ \179\000\000\000\000\000\000\000\000\000\021\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\189\000\000\000\000\000\010\002\000\000\ \046\255\000\000\046\255\000\000\000\000\208\000\000\000\046\255\ \000\000\046\255\000\000\046\255\000\000\220\000\216\000\235\000\ \046\255\046\255\066\002\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\046\255\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\001\061\255\104\003\054\003\000\000\009\255\ \000\000\046\255\000\000\046\255\000\000\000\000\094\001\000\000\ \000\000\022\000\064\000\085\000\000\000\000\000\254\000\046\255\ \067\000\067\000\015\001\004\001\252\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\104\003\046\255\046\255\000\000\ \046\255\150\002\000\000\012\001\000\000\000\000\018\001\000\000\ \000\000\000\000\000\000\000\000\220\000\000\000\000\000\046\255\ \150\002\019\001\000\000\024\001\000\000\046\255\000\000\022\001\ \026\001\000\000\000\000\030\001\000\000\046\255\000\000\032\001\ \000\000" let yyrindex = "\000\000\ \000\000\033\001\084\255\000\000\000\000\004\003\000\000\000\000\ \000\000\000\000\000\000\000\000\057\001\000\000\000\000\000\000\ \000\000\000\000\107\255\048\001\046\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\226\255\060\000\097\000\000\000\000\000\000\000\152\001\ \017\255\000\000\000\000\000\000\068\000\094\000\122\000\127\000\ \062\255\000\000\000\000\000\000\000\000\035\001\000\000\000\000\ \210\000\000\000\000\000\000\000\188\255\000\000\000\000\000\000\ \000\000\000\000\000\000\033\001\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\185\000\222\000\123\001\064\001\ \222\000\033\001\123\001\000\000\181\001\000\000\181\001\181\001\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\245\000\000\000\210\001\239\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \079\001\000\000\000\000\185\000\000\000\000\000\057\001\000\000\ \000\000\000\000\000\000\000\000\000\000\081\001\000\000\000\000\ \082\001\083\001\000\000\000\000\099\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\110\000\000\000\110\000\000\000\ \110\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\233\002\000\000\000\000\000\000\000\000\000\000\ \233\002\000\000\000\000\062\001\065\001\068\001\000\000\000\000\ \000\000\185\255\150\003\150\003\150\003\000\000\000\000\000\000\ \144\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\087\001\000\000\ \123\001\000\000\222\000\000\000\000\000\000\000\000\000\222\000\ \000\000\222\000\000\000\222\000\000\000\085\001\045\255\175\255\ \143\000\048\001\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\233\002\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\077\255\000\000\000\000\000\000\000\000\086\001\ \000\000\185\000\000\000\222\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\094\002\000\000\000\000\150\003\ \000\000\000\000\090\001\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\073\001\033\001\007\000\000\000\ \033\001\005\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\085\001\000\000\000\000\085\001\ \078\001\000\000\000\000\000\000\000\000\143\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\143\000\000\000\000\000\ \000\000" let yygindex = "\000\000\ \000\000\000\000\000\000\000\000\000\000\254\255\000\000\000\000\ \237\254\125\254\000\000\049\001\050\001\217\254\074\001\076\001\ \176\255\253\255\103\001\000\000\000\000\000\000\008\000\000\000\ \134\000\210\255\104\000\002\000\000\000\000\000\000\000\072\000\ \000\000\190\255\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\147\001\000\000\ \255\000\000\000\136\001\000\000\000\000\239\255\000\000\000\000\ \201\000\091\001\000\000\097\001\088\000\114\001\000\000\000\000\ \000\000\000\000\128\001\095\001\000\000\000\000\000\000\231\254\ \000\000\000\000\000\000\000\000\000\000" let yytablesize = 1257 let yytable = "\033\000\ \179\000\068\000\058\000\040\000\052\001\035\001\054\001\056\001\ \066\001\039\000\060\000\134\001\088\001\236\001\091\001\092\001\ \066\000\070\000\044\000\048\000\048\000\048\000\048\000\048\000\ \044\000\034\001\044\000\048\000\044\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\051\000\048\000\027\001\048\000\048\000\048\000\051\000\ \008\000\051\000\106\000\125\000\142\000\159\000\178\000\194\000\ \214\000\071\000\051\000\190\001\209\001\008\000\008\002\075\000\ \001\001\030\001\009\002\075\000\023\001\075\000\075\000\075\000\ \069\000\044\000\038\001\045\001\046\001\047\001\181\001\050\001\ \051\001\053\001\181\001\055\001\057\001\092\000\092\000\092\000\ \092\000\092\000\092\000\092\000\092\000\092\000\092\000\092\000\ \092\000\092\000\092\000\092\000\092\000\092\000\092\000\092\000\ \092\000\092\000\092\000\092\000\179\001\092\000\183\001\092\000\ \092\000\092\000\108\000\126\000\143\000\160\000\180\000\195\000\ \215\000\003\002\083\000\090\000\091\000\092\000\093\000\094\000\ \002\001\073\000\074\000\013\000\024\001\095\000\096\000\097\000\ \098\000\099\000\100\000\101\000\102\000\103\000\104\000\105\000\ \026\000\084\000\027\000\076\000\028\000\029\000\030\000\085\000\ \130\001\007\000\036\002\008\000\009\000\010\000\011\000\012\000\ \131\001\089\000\040\002\013\000\014\000\015\000\016\000\017\000\ \018\000\019\000\020\000\021\000\022\000\023\000\024\000\025\000\ \026\000\050\000\027\000\050\000\028\000\029\000\030\000\015\002\ \032\001\033\001\183\001\190\001\088\001\098\000\183\001\184\001\ \183\001\183\001\183\001\135\001\183\001\169\000\012\002\171\000\ \172\000\173\000\137\001\131\001\005\001\162\000\163\000\164\000\ \165\000\166\000\131\001\006\001\217\000\013\000\063\001\167\000\ \168\000\169\000\170\000\171\000\172\000\173\000\174\000\175\000\ \176\000\177\000\026\000\060\000\027\000\029\001\028\000\029\000\ \030\000\060\000\104\001\190\001\105\001\106\001\107\001\108\001\ \109\001\110\001\111\001\013\000\112\001\113\001\114\001\115\001\ \116\001\117\001\118\001\119\001\120\001\121\001\122\001\123\001\ \026\000\060\001\027\000\061\001\028\000\029\000\030\000\065\001\ \183\001\117\000\214\000\117\000\183\001\139\001\143\001\031\001\ \182\000\183\000\184\000\185\000\186\000\131\001\219\001\016\002\ \013\000\038\001\187\000\188\000\067\001\189\000\220\001\131\001\ \001\001\190\000\191\000\192\000\193\000\026\000\028\001\027\000\ \058\001\028\000\029\000\030\000\086\000\080\001\040\000\057\000\ \057\000\062\001\087\000\088\000\039\000\125\001\090\001\226\001\ \129\001\227\001\125\001\228\001\057\000\061\000\057\000\057\000\ \057\000\017\002\132\001\061\000\093\001\063\000\136\001\063\000\ \148\001\131\001\215\000\063\000\063\000\063\000\149\001\063\000\ \063\000\169\000\138\001\171\000\172\000\173\000\018\002\211\001\ \213\001\214\001\214\001\166\001\186\001\206\001\131\001\064\000\ \002\001\064\000\047\000\140\001\088\000\064\000\064\000\064\000\ \047\000\064\000\064\000\061\000\088\000\082\001\141\001\084\000\ \062\000\063\000\064\000\145\001\044\000\126\001\065\000\084\000\ \146\001\081\000\126\001\065\000\082\000\065\000\223\001\224\001\ \066\000\065\000\065\000\065\000\077\000\065\000\066\000\066\000\ \066\000\078\000\066\000\230\001\079\000\080\000\235\001\237\001\ \183\001\060\000\001\000\002\000\003\000\069\000\183\001\183\001\ \183\001\060\000\001\002\167\001\187\001\207\001\218\000\219\000\ \220\000\221\000\222\000\223\000\224\000\225\000\013\000\226\000\ \227\000\228\000\229\000\230\000\231\000\232\000\233\000\234\000\ \235\000\236\000\237\000\026\000\036\001\027\000\218\001\028\000\ \029\000\030\000\021\002\022\002\183\001\183\001\221\001\005\002\ \183\001\183\001\183\001\183\001\183\001\183\001\183\001\183\001\ \183\001\183\001\183\001\183\001\183\001\183\001\183\001\183\001\ \183\001\225\001\183\001\094\000\183\001\183\001\183\001\038\001\ \013\002\094\000\002\002\094\000\186\001\080\001\229\001\183\001\ \233\001\183\001\183\001\183\001\183\001\214\001\125\001\183\001\ \183\001\183\001\183\001\183\001\183\001\183\001\183\001\183\001\ \183\001\183\001\183\001\183\001\183\001\183\001\095\000\183\001\ \234\001\183\001\183\001\183\001\095\000\183\001\095\000\183\001\ \183\001\183\001\019\002\026\002\027\002\023\002\028\002\062\000\ \063\000\064\000\024\002\006\002\186\001\055\000\056\000\008\000\ \030\002\166\001\230\001\031\002\034\002\033\002\062\000\063\000\ \064\000\035\002\037\002\235\001\187\001\082\001\038\002\039\002\ \166\001\041\002\183\001\235\001\091\000\133\001\126\001\105\001\ \106\001\107\001\108\001\109\001\110\001\111\001\013\000\112\001\ \113\001\114\001\115\001\116\001\117\001\118\001\119\001\120\001\ \121\001\122\001\123\001\026\000\183\001\027\000\183\001\028\000\ \029\000\030\000\121\000\121\000\121\000\122\000\122\000\122\000\ \123\000\123\000\123\000\183\001\187\001\124\000\124\000\124\000\ \099\000\167\001\125\000\125\000\125\000\108\000\112\000\113\000\ \105\000\183\001\114\000\181\001\025\002\097\001\098\001\014\002\ \167\001\105\001\106\001\107\001\108\001\109\001\110\001\111\001\ \013\000\112\001\113\001\114\001\115\001\116\001\117\001\118\001\ \119\001\120\001\121\001\122\001\123\001\026\000\099\001\027\000\ \100\001\028\000\029\000\030\000\183\001\222\001\183\001\183\001\ \183\001\183\001\183\001\183\001\183\001\183\001\183\001\183\001\ \183\001\183\001\183\001\183\001\183\001\183\001\183\001\183\001\ \183\001\183\001\183\001\101\001\183\001\059\001\183\001\183\001\ \183\001\043\000\032\002\049\000\049\000\049\000\049\000\043\000\ \064\001\043\000\049\000\043\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \020\002\049\000\168\001\049\000\049\000\049\000\183\001\216\001\ \183\001\183\001\183\001\183\001\183\001\217\001\183\001\183\001\ \183\001\183\001\183\001\183\001\183\001\183\001\183\001\183\001\ \183\001\183\001\183\001\183\001\183\001\215\001\183\001\000\000\ \183\001\183\001\183\001\183\001\188\001\183\001\183\001\183\001\ \183\001\000\000\000\000\000\000\183\001\183\001\183\001\183\001\ \183\001\183\001\183\001\183\001\183\001\183\001\183\001\183\001\ \183\001\183\001\000\000\183\001\000\000\183\001\183\001\183\001\ \218\000\219\000\220\000\221\000\222\000\223\000\224\000\225\000\ \013\000\226\000\227\000\228\000\229\000\230\000\231\000\232\000\ \233\000\234\000\235\000\236\000\237\000\026\000\000\000\027\000\ \037\001\028\000\029\000\030\000\218\000\219\000\220\000\221\000\ \222\000\223\000\224\000\225\000\013\000\226\000\227\000\228\000\ \229\000\230\000\231\000\232\000\233\000\234\000\235\000\236\000\ \237\000\026\000\000\000\027\000\000\000\028\000\029\000\030\000\ \033\001\241\000\242\000\243\000\244\000\062\000\063\000\064\000\ \013\000\245\000\246\000\247\000\248\000\249\000\250\000\251\000\ \252\000\253\000\254\000\255\000\000\001\026\000\000\000\027\000\ \000\000\028\000\029\000\030\000\238\001\068\001\239\001\240\001\ \241\001\242\001\243\001\244\001\013\000\245\001\246\001\247\001\ \248\001\249\001\250\001\251\001\252\001\253\001\254\001\255\001\ \000\002\026\000\000\000\027\000\000\000\028\000\029\000\030\000\ \149\000\149\000\184\001\000\000\000\000\149\000\149\000\149\000\ \149\000\149\000\149\000\149\000\149\000\149\000\149\000\149\000\ \149\000\149\000\149\000\149\000\149\000\149\000\000\000\149\000\ \000\000\149\000\149\000\149\000\197\000\198\000\199\000\200\000\ \201\000\000\000\000\000\000\000\013\000\202\000\203\000\204\000\ \205\000\206\000\207\000\208\000\209\000\210\000\211\000\212\000\ \213\000\026\000\000\000\027\000\000\000\028\000\029\000\030\000\ \150\001\068\001\000\000\000\000\000\000\151\001\152\001\153\001\ \013\000\154\001\155\001\156\001\157\001\158\001\159\001\160\001\ \161\001\162\001\163\001\164\001\165\001\026\000\000\000\027\000\ \000\000\028\000\029\000\030\000\128\000\000\000\129\000\130\000\ \131\000\000\000\000\000\000\000\013\000\000\000\000\000\132\000\ \133\000\134\000\135\000\136\000\137\000\138\000\139\000\140\000\ \141\000\026\000\000\000\027\000\000\000\028\000\029\000\030\000\ \145\000\000\000\146\000\147\000\148\000\000\000\000\000\000\000\ \013\000\000\000\000\000\149\000\150\000\151\000\152\000\153\000\ \154\000\155\000\156\000\157\000\158\000\026\000\000\000\027\000\ \000\000\028\000\029\000\030\000\183\001\183\001\183\001\183\001\ \183\001\183\001\183\001\183\001\183\001\183\001\183\001\183\001\ \183\001\183\001\183\001\183\001\183\001\183\001\183\001\183\001\ \183\001\000\000\183\001\000\000\183\001\183\001\183\001\183\001\ \183\001\183\001\183\001\183\001\000\000\000\000\183\001\183\001\ \183\001\183\001\183\001\183\001\183\001\183\001\183\001\183\001\ \183\001\183\001\183\001\183\001\000\000\183\001\000\000\183\001\ \183\001\183\001\241\000\242\000\243\000\244\000\000\000\000\000\ \000\000\013\000\245\000\246\000\247\000\248\000\249\000\250\000\ \251\000\252\000\253\000\254\000\255\000\000\001\026\000\000\000\ \027\000\068\001\028\000\029\000\030\000\069\001\070\001\071\001\ \013\000\072\001\073\001\074\001\169\000\075\001\171\000\172\000\ \173\000\076\001\077\001\078\001\079\001\026\000\000\000\027\000\ \000\000\028\000\029\000\030\000\009\000\010\000\011\000\012\000\ \000\000\000\000\000\000\013\000\014\000\015\000\016\000\017\000\ \018\000\094\001\095\001\096\001\022\000\023\000\024\000\025\000\ \026\000\000\000\027\000\068\001\028\000\029\000\030\000\171\001\ \172\001\173\001\013\000\174\001\175\001\176\001\177\001\178\001\ \179\001\180\001\181\001\182\001\183\001\184\001\185\001\026\000\ \000\000\027\000\068\001\028\000\029\000\030\000\191\001\192\001\ \193\001\013\000\194\001\195\001\196\001\197\001\198\001\199\001\ \200\001\201\001\202\001\203\001\204\001\205\001\026\000\000\000\ \027\000\183\001\028\000\029\000\030\000\183\001\183\001\183\001\ \183\001\183\001\183\001\183\001\183\001\183\001\183\001\183\001\ \183\001\183\001\183\001\183\001\183\001\183\001\000\000\183\001\ \000\000\183\001\183\001\183\001\110\000\111\000\112\000\113\000\ \000\000\000\000\000\000\013\000\000\000\114\000\115\000\116\000\ \117\000\118\000\119\000\120\000\121\000\122\000\123\000\124\000\ \026\000\000\000\027\000\000\000\028\000\029\000\030\000\007\001\ \008\001\009\001\062\000\063\000\064\000\013\000\010\001\011\001\ \012\001\013\001\014\001\015\001\016\001\017\001\018\001\019\001\ \020\001\021\001\026\000\000\000\027\000\000\000\028\000\029\000\ \030\000" let yycheck = "\002\000\ \047\000\019\000\006\000\002\000\085\000\072\000\087\000\088\000\ \028\001\002\000\013\000\051\001\038\001\145\001\006\001\007\001\ \019\000\020\000\002\001\003\001\004\001\005\001\006\001\007\001\ \008\001\072\000\010\001\011\001\012\001\013\001\014\001\015\001\ \016\001\017\001\018\001\019\001\020\001\021\001\022\001\023\001\ \024\001\001\001\026\001\061\000\028\001\029\001\030\001\003\001\ \003\001\005\001\043\000\044\000\045\000\046\000\047\000\048\000\ \049\000\014\001\014\001\085\001\086\001\003\001\002\001\002\001\ \057\000\068\000\006\001\001\001\061\000\008\001\009\001\010\001\ \014\001\002\000\077\000\078\000\079\000\080\000\002\001\082\000\ \083\000\085\000\006\001\087\000\088\000\002\001\003\001\004\001\ \005\001\006\001\007\001\008\001\009\001\010\001\011\001\012\001\ \013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\ \021\001\022\001\023\001\024\001\002\001\026\001\004\001\028\001\ \029\001\030\001\043\000\044\000\045\000\046\000\047\000\048\000\ \049\000\147\001\012\001\003\001\004\001\005\001\006\001\007\001\ \057\000\026\000\027\000\011\001\061\000\013\001\014\001\015\001\ \016\001\017\001\018\001\019\001\020\001\021\001\022\001\023\001\ \024\001\002\001\026\001\002\001\028\001\029\001\030\001\008\001\ \002\001\001\001\030\002\003\001\004\001\005\001\006\001\007\001\ \010\001\003\001\038\002\011\001\012\001\013\001\014\001\015\001\ \016\001\017\001\018\001\019\001\020\001\021\001\022\001\023\001\ \024\001\003\001\026\001\005\001\028\001\029\001\030\001\223\001\ \002\001\003\001\002\001\213\001\214\001\002\001\006\001\004\001\ \008\001\009\001\010\001\002\001\012\001\015\001\218\001\017\001\ \018\001\019\001\002\001\010\001\008\001\003\001\004\001\005\001\ \006\001\007\001\010\001\004\001\002\001\011\001\025\001\013\001\ \014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\ \022\001\023\001\024\001\002\001\026\001\002\001\028\001\029\001\ \030\001\008\001\002\001\005\002\004\001\005\001\006\001\007\001\ \008\001\009\001\010\001\011\001\012\001\013\001\014\001\015\001\ \016\001\017\001\018\001\019\001\020\001\021\001\022\001\023\001\ \024\001\005\001\026\001\006\001\028\001\029\001\030\001\025\001\ \002\001\005\001\003\001\007\001\006\001\002\001\061\001\015\001\ \003\001\004\001\005\001\006\001\007\001\010\001\002\001\002\001\ \011\001\028\001\013\001\014\001\031\001\016\001\010\001\010\001\ \025\001\020\001\021\001\022\001\023\001\024\001\004\001\026\001\ \001\001\028\001\029\001\030\001\002\001\038\001\045\001\002\001\ \003\001\002\001\008\001\009\001\045\001\046\001\005\001\136\001\ \012\001\138\001\051\001\140\001\015\001\002\001\017\001\018\001\ \019\001\002\001\002\001\008\001\007\001\002\001\008\001\004\001\ \075\001\010\001\003\001\008\001\009\001\010\001\081\001\012\001\ \013\001\015\001\008\001\017\001\018\001\019\001\002\001\090\001\ \091\001\092\001\093\001\084\001\085\001\086\001\010\001\002\001\ \025\001\004\001\002\001\008\001\002\001\008\001\009\001\010\001\ \008\001\012\001\013\001\003\001\010\001\038\001\002\001\002\001\ \008\001\009\001\010\001\005\001\045\001\046\001\014\001\010\001\ \004\001\009\001\051\001\002\001\012\001\014\001\129\001\131\001\ \002\001\008\001\009\001\010\001\004\001\012\001\008\001\009\001\ \010\001\009\001\012\001\142\001\012\001\013\001\145\001\146\001\ \002\001\002\001\001\000\002\000\003\000\014\001\008\001\009\001\ \010\001\010\001\147\001\084\001\085\001\086\001\003\001\004\001\ \005\001\006\001\007\001\008\001\009\001\010\001\011\001\012\001\ \013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\ \021\001\022\001\023\001\024\001\025\001\026\001\004\001\028\001\ \029\001\030\001\233\001\234\001\004\001\005\001\002\001\194\001\ \008\001\009\001\010\001\011\001\012\001\013\001\014\001\015\001\ \016\001\017\001\018\001\019\001\020\001\021\001\022\001\023\001\ \024\001\002\001\026\001\002\001\028\001\029\001\030\001\218\001\ \220\001\008\001\147\001\010\001\213\001\214\001\003\001\002\001\ \009\001\004\001\005\001\006\001\007\001\232\001\223\001\010\001\ \011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ \019\001\020\001\021\001\022\001\023\001\024\001\002\001\026\001\ \014\001\028\001\029\001\030\001\008\001\015\001\010\001\017\001\ \018\001\019\001\005\001\006\002\007\002\002\001\009\002\008\001\ \009\001\010\001\015\001\012\001\005\002\001\001\002\001\003\001\ \005\001\010\002\021\002\002\001\002\001\024\002\008\001\009\001\ \010\001\002\001\005\001\030\002\213\001\214\001\005\001\002\001\ \025\002\002\001\002\001\038\002\002\001\002\001\223\001\004\001\ \005\001\006\001\007\001\008\001\009\001\010\001\011\001\012\001\ \013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\ \021\001\022\001\023\001\024\001\004\001\026\001\015\001\028\001\ \029\001\030\001\005\001\006\001\007\001\005\001\006\001\007\001\ \005\001\006\001\007\001\012\001\005\002\005\001\006\001\007\001\ \002\001\010\002\005\001\006\001\007\001\005\001\005\001\005\001\ \002\001\005\001\005\001\002\001\005\002\045\001\045\001\002\001\ \025\002\004\001\005\001\006\001\007\001\008\001\009\001\010\001\ \011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ \019\001\020\001\021\001\022\001\023\001\024\001\045\001\026\001\ \045\001\028\001\029\001\030\001\002\001\127\001\004\001\005\001\ \006\001\007\001\008\001\009\001\010\001\011\001\012\001\013\001\ \014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\ \022\001\023\001\024\001\045\001\026\001\003\001\028\001\029\001\ \030\001\002\001\021\002\004\001\005\001\006\001\007\001\008\001\ \025\001\010\001\011\001\012\001\013\001\014\001\015\001\016\001\ \017\001\018\001\019\001\020\001\021\001\022\001\023\001\024\001\ \232\001\026\001\084\001\028\001\029\001\030\001\002\001\093\001\ \004\001\005\001\006\001\007\001\008\001\093\001\010\001\011\001\ \012\001\013\001\014\001\015\001\016\001\017\001\018\001\019\001\ \020\001\021\001\022\001\023\001\024\001\092\001\026\001\255\255\ \028\001\029\001\030\001\002\001\085\001\004\001\005\001\006\001\ \007\001\255\255\255\255\255\255\011\001\012\001\013\001\014\001\ \015\001\016\001\017\001\018\001\019\001\020\001\021\001\022\001\ \023\001\024\001\255\255\026\001\255\255\028\001\029\001\030\001\ \003\001\004\001\005\001\006\001\007\001\008\001\009\001\010\001\ \011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ \019\001\020\001\021\001\022\001\023\001\024\001\255\255\026\001\ \027\001\028\001\029\001\030\001\003\001\004\001\005\001\006\001\ \007\001\008\001\009\001\010\001\011\001\012\001\013\001\014\001\ \015\001\016\001\017\001\018\001\019\001\020\001\021\001\022\001\ \023\001\024\001\255\255\026\001\255\255\028\001\029\001\030\001\ \003\001\004\001\005\001\006\001\007\001\008\001\009\001\010\001\ \011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ \019\001\020\001\021\001\022\001\023\001\024\001\255\255\026\001\ \255\255\028\001\029\001\030\001\003\001\004\001\005\001\006\001\ \007\001\008\001\009\001\010\001\011\001\012\001\013\001\014\001\ \015\001\016\001\017\001\018\001\019\001\020\001\021\001\022\001\ \023\001\024\001\255\255\026\001\255\255\028\001\029\001\030\001\ \003\001\004\001\005\001\255\255\255\255\008\001\009\001\010\001\ \011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ \019\001\020\001\021\001\022\001\023\001\024\001\255\255\026\001\ \255\255\028\001\029\001\030\001\003\001\004\001\005\001\006\001\ \007\001\255\255\255\255\255\255\011\001\012\001\013\001\014\001\ \015\001\016\001\017\001\018\001\019\001\020\001\021\001\022\001\ \023\001\024\001\255\255\026\001\255\255\028\001\029\001\030\001\ \003\001\004\001\255\255\255\255\255\255\008\001\009\001\010\001\ \011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ \019\001\020\001\021\001\022\001\023\001\024\001\255\255\026\001\ \255\255\028\001\029\001\030\001\003\001\255\255\005\001\006\001\ \007\001\255\255\255\255\255\255\011\001\255\255\255\255\014\001\ \015\001\016\001\017\001\018\001\019\001\020\001\021\001\022\001\ \023\001\024\001\255\255\026\001\255\255\028\001\029\001\030\001\ \003\001\255\255\005\001\006\001\007\001\255\255\255\255\255\255\ \011\001\255\255\255\255\014\001\015\001\016\001\017\001\018\001\ \019\001\020\001\021\001\022\001\023\001\024\001\255\255\026\001\ \255\255\028\001\029\001\030\001\004\001\005\001\006\001\007\001\ \008\001\009\001\010\001\011\001\012\001\013\001\014\001\015\001\ \016\001\017\001\018\001\019\001\020\001\021\001\022\001\023\001\ \024\001\255\255\026\001\255\255\028\001\029\001\030\001\004\001\ \005\001\006\001\007\001\008\001\255\255\255\255\011\001\012\001\ \013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\ \021\001\022\001\023\001\024\001\255\255\026\001\255\255\028\001\ \029\001\030\001\004\001\005\001\006\001\007\001\255\255\255\255\ \255\255\011\001\012\001\013\001\014\001\015\001\016\001\017\001\ \018\001\019\001\020\001\021\001\022\001\023\001\024\001\255\255\ \026\001\004\001\028\001\029\001\030\001\008\001\009\001\010\001\ \011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ \019\001\020\001\021\001\022\001\023\001\024\001\255\255\026\001\ \255\255\028\001\029\001\030\001\004\001\005\001\006\001\007\001\ \255\255\255\255\255\255\011\001\012\001\013\001\014\001\015\001\ \016\001\017\001\018\001\019\001\020\001\021\001\022\001\023\001\ \024\001\255\255\026\001\004\001\028\001\029\001\030\001\008\001\ \009\001\010\001\011\001\012\001\013\001\014\001\015\001\016\001\ \017\001\018\001\019\001\020\001\021\001\022\001\023\001\024\001\ \255\255\026\001\004\001\028\001\029\001\030\001\008\001\009\001\ \010\001\011\001\012\001\013\001\014\001\015\001\016\001\017\001\ \018\001\019\001\020\001\021\001\022\001\023\001\024\001\255\255\ \026\001\004\001\028\001\029\001\030\001\008\001\009\001\010\001\ \011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ \019\001\020\001\021\001\022\001\023\001\024\001\255\255\026\001\ \255\255\028\001\029\001\030\001\004\001\005\001\006\001\007\001\ \255\255\255\255\255\255\011\001\255\255\013\001\014\001\015\001\ \016\001\017\001\018\001\019\001\020\001\021\001\022\001\023\001\ \024\001\255\255\026\001\255\255\028\001\029\001\030\001\005\001\ \006\001\007\001\008\001\009\001\010\001\011\001\012\001\013\001\ \014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\ \022\001\023\001\024\001\255\255\026\001\255\255\028\001\029\001\ \030\001" let yynames_const = "\ " let yynames_block = "\ TokEof\000\ TokEol\000\ TokWhite\000\ TokLeftParen\000\ TokRightParen\000\ TokArrow\000\ TokComma\000\ TokColon\000\ TokDoubleColon\000\ TokNamedColon\000\ TokDollar\000\ TokEq\000\ TokArray\000\ TokDot\000\ TokId\000\ TokKey\000\ TokKeyword\000\ TokCatch\000\ TokClass\000\ TokOp\000\ TokInt\000\ TokFloat\000\ TokString\000\ TokBeginQuote\000\ TokEndQuote\000\ TokBeginQuoteString\000\ TokEndQuoteString\000\ TokStringQuote\000\ TokVar\000\ TokVarQuote\000\ " let yyact = [| (fun _ -> failwith "parser") ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 214 "omake_ast_parse.mly" ( raise End_of_file ) # 939 "omake_ast_parse.ml" : Omake_ast.body_flag * Omake_ast.exp)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'text) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 216 "omake_ast_parse.mly" ( NoBody, sequence_exp _1 _2 ) # 948 "omake_ast_parse.ml" : Omake_ast.body_flag * Omake_ast.exp)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 224 "omake_ast_parse.mly" ( raise End_of_file ) # 955 "omake_ast_parse.ml" : Omake_ast.body_flag * Omake_ast.exp)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'shell_line) in let _2 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 226 "omake_ast_parse.mly" ( _1 ) # 963 "omake_ast_parse.ml" : Omake_ast.body_flag * Omake_ast.exp)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 232 "omake_ast_parse.mly" ( NoBody, sequence_exp [] _2 ) # 971 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'keyword_text_optcolon) in let _4 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 236 "omake_ast_parse.mly" ( let id, loc1 = _1 in let body, arg = get_optcolon_text _3 _4 in let loc = Lm_location.union_loc loc1 _4 in body, CommandExp (Lm_symbol.add id, arg, [], loc) ) # 985 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : 'opt_literal_colon) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 242 "omake_ast_parse.mly" ( let id, loc1 = _1 in let body = _2 in let loc = Lm_location.union_loc loc1 _3 in let arg = Omake_ast.NullExp loc in body, CommandExp (Lm_symbol.add id, arg, [], loc) ) # 999 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 6 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 5 : 'opt_white) in let _3 = (Parsing.peek_val __caml_parser_env 4 : string * Lm_location.t) in let _4 = (Parsing.peek_val __caml_parser_env 3 : 'opt_args) in let _5 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _6 = (Parsing.peek_val __caml_parser_env 1 : 'opt_colon) in let _7 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 251 "omake_ast_parse.mly" ( let id, loc1 = _1 in let body = _6 in let loc = Lm_location.union_loc loc1 _7 in let args = args_of_parse_args _4 in let e = Omake_ast.ApplyExp (CommandApply, Lm_symbol.add id, args, loc) in body, e ) # 1018 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 10 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 9 : 'opt_white) in let _3 = (Parsing.peek_val __caml_parser_env 8 : string * Lm_location.t) in let _4 = (Parsing.peek_val __caml_parser_env 7 : 'opt_white) in let _5 = (Parsing.peek_val __caml_parser_env 6 : string * Lm_location.t) in let _6 = (Parsing.peek_val __caml_parser_env 5 : 'opt_white) in let _7 = (Parsing.peek_val __caml_parser_env 4 : string * Lm_location.t) in let _8 = (Parsing.peek_val __caml_parser_env 3 : 'opt_white) in let _9 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _10 = (Parsing.peek_val __caml_parser_env 1 : 'opt_colon) in let _11 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 261 "omake_ast_parse.mly" ( let _, loc1 = _1 in let loc = Lm_location.union_loc loc1 _11 in let name, _ = _3 in let v, _ = _7 in _10, CatchExp (Lm_symbol.add name, Lm_symbol.add v, [], loc) ) # 1040 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : 'opt_id_list) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 270 "omake_ast_parse.mly" ( let _, loc1 = _1 in let loc = Lm_location.union_loc loc1 _3 in NoBody, ClassExp (List.map Lm_symbol.add _2, loc) ) # 1052 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'method_id_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_white) in let _4 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 277 "omake_ast_parse.mly" ( let id, loc1 = _1 in let loc2 = _4 in let id = method_id_intern id in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag _2 in ColonBody, VarDefBodyExp (id, DefineString, add_flag, [], loc) ) # 1068 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'method_id_prefix_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_white) in let _4 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 287 "omake_ast_parse.mly" ( let id, loc1 = _1 in let loc2 = _4 in let id = method_id_intern id in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag _2 in ColonBody, ObjectDefExp (id, add_flag, [], loc) ) # 1084 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 4 : 'method_id_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 3 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 2 : 'opt_white) in let _4 = (Parsing.peek_val __caml_parser_env 1 : 'text_nonempty) in let _5 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 297 "omake_ast_parse.mly" ( let id, loc1 = _1 in let loc2 = _5 in let e = simplify _4 in let id = method_id_intern id in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag _2 in NoBody, VarDefExp (id, DefineString, add_flag, e, loc) ) # 1102 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'var_quote_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_white) in let _4 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 308 "omake_ast_parse.mly" ( let _, id, loc1 = _1 in let loc2 = _4 in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag _2 in ColonBody, KeyDefBodyExp (id, DefineString, add_flag, [], loc) ) # 1117 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 4 : 'var_quote_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 3 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 2 : 'opt_white) in let _4 = (Parsing.peek_val __caml_parser_env 1 : 'text_nonempty) in let _5 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 317 "omake_ast_parse.mly" ( let _, id, loc1 = _1 in let loc2 = _5 in let e = simplify _4 in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag _2 in NoBody, KeyDefExp (id, DefineString, add_flag, e, loc) ) # 1134 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 5 : 'method_id_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 4 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 3 : 'opt_white) in let _4 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_white) in let _6 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 327 "omake_ast_parse.mly" ( let id, loc1 = _1 in let loc2 = _6 in let id = method_id_intern id in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag _4 in ArrayBody, VarDefBodyExp (id, DefineArray, add_flag, [], loc) ) # 1152 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 6 : 'method_id_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 5 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 4 : 'opt_white) in let _4 = (Parsing.peek_val __caml_parser_env 3 : string * Lm_location.t) in let _5 = (Parsing.peek_val __caml_parser_env 2 : 'opt_white) in let _6 = (Parsing.peek_val __caml_parser_env 1 : 'text_nonempty) in let _7 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 337 "omake_ast_parse.mly" ( let id, loc1 = _1 in let loc2 = _7 in let id = method_id_intern id in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag _4 in NoBody, VarDefExp (id, DefineArray, add_flag, _6, loc) ) # 1171 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 5 : 'method_id_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 4 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 3 : 'opt_args) in let _4 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_colon) in let _6 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 347 "omake_ast_parse.mly" ( let id, loc1 = _1 in let body = _5 in let loc = Lm_location.union_loc loc1 _6 in let args = args_of_parse_args _3 in let e = match id with [id] -> Omake_ast.ApplyExp (CommandApply, Lm_symbol.add id, args, loc) | _ -> MethodApplyExp (CommandApply, method_id_intern id, args, loc) in body, e ) # 1195 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 7 : 'method_id_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 6 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 5 : 'opt_args) in let _4 = (Parsing.peek_val __caml_parser_env 4 : string * Lm_location.t) in let _5 = (Parsing.peek_val __caml_parser_env 3 : 'opt_colon) in let _6 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _7 = (Parsing.peek_val __caml_parser_env 1 : 'opt_white) in let _8 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 363 "omake_ast_parse.mly" ( let id, loc1 = _1 in let body = _5 in let loc = Lm_location.union_loc loc1 _8 in let params = get_fun_params _3 in let arg = Omake_ast.ArrowArg (params, StringOpExp ("...", loc)) in let e = match id with [id] -> Omake_ast.ApplyExp (CommandApply, Lm_symbol.add id, [arg], loc) | _ -> MethodApplyExp (CommandApply, method_id_intern id, [arg], loc) in body, e ) # 1222 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 7 : 'method_id_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 6 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 5 : 'opt_args) in let _4 = (Parsing.peek_val __caml_parser_env 4 : string * Lm_location.t) in let _5 = (Parsing.peek_val __caml_parser_env 3 : 'opt_white) in let _6 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _7 = (Parsing.peek_val __caml_parser_env 1 : 'opt_white) in let _8 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 380 "omake_ast_parse.mly" ( let id, loc1 = _1 in let id = method_id_intern id in let params = get_fun_params _3 in let loc = Lm_location.union_loc loc1 _8 in ColonBody, FunDefExp (id, params, [], loc) ) # 1241 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'other_id_target) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'source) in let _4 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 389 "omake_ast_parse.mly" ( ColonBody, rule2 false _1 _2 _3 _4 [] ) # 1251 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 5 : 'other_id_target) in let _2 = (Parsing.peek_val __caml_parser_env 4 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 3 : 'target) in let _4 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _5 = (Parsing.peek_val __caml_parser_env 1 : 'source) in let _6 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 391 "omake_ast_parse.mly" ( ColonBody, rule3 false _1 _2 _3 _5 _6 [] ) # 1263 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'other_target) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'source) in let _4 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 393 "omake_ast_parse.mly" ( ColonBody, rule2 false _1 _2 _3 _4 [] ) # 1273 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'other_target) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'source) in let _4 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 395 "omake_ast_parse.mly" ( ColonBody, rule2 true _1 _2 _3 _4 [] ) # 1283 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 5 : 'other_target) in let _2 = (Parsing.peek_val __caml_parser_env 4 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 3 : 'target) in let _4 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _5 = (Parsing.peek_val __caml_parser_env 1 : 'source) in let _6 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 397 "omake_ast_parse.mly" ( ColonBody, rule3 false _1 _2 _3 _5 _6 [] ) # 1295 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 5 : 'other_target) in let _2 = (Parsing.peek_val __caml_parser_env 4 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 3 : 'target) in let _4 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _5 = (Parsing.peek_val __caml_parser_env 1 : 'source) in let _6 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 399 "omake_ast_parse.mly" ( ColonBody, rule3 true _1 _2 _3 _5 _6 [] ) # 1307 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 4 : 'method_id_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 3 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 2 : 'opt_white) in let _4 = (Parsing.peek_val __caml_parser_env 1 : 'source_nonapply) in let _5 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 407 "omake_ast_parse.mly" ( let idl, loc = _1 in let e = method_id_string_exp idl loc in ColonBody, rule2 true (e, loc) _2 _4 _5 [] ) # 1321 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'method_id_prefix_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'source) in let _4 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 412 "omake_ast_parse.mly" ( let idl, loc = _1 in let e = method_id_prefix_string_exp idl loc in ColonBody, rule2 true (e, loc) _2 _3 _4 [] ) # 1334 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 8 : 'method_id_opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 7 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 6 : 'opt_white) in let _4 = (Parsing.peek_val __caml_parser_env 5 : 'method_id_opt_white) in let _5 = (Parsing.peek_val __caml_parser_env 4 : string * Lm_location.t) in let _6 = (Parsing.peek_val __caml_parser_env 3 : 'opt_args) in let _7 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _8 = (Parsing.peek_val __caml_parser_env 1 : 'opt_colon) in let _9 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 417 "omake_ast_parse.mly" ( let super, loc1 = _1 in let name, _ = _4 in let body = _8 in let loc = Lm_location.union_loc loc1 _9 in let args = args_of_parse_args _6 in let e = match super, name with [super], [name] -> Omake_ast.SuperApplyExp (CommandApply, Lm_symbol.add super, Lm_symbol.add name, args, loc) | _, [_] -> raise (Omake_value_type.OmakeException (loc_exp_pos loc, StringStringError ("illegal super class", method_id_string super))) | _ -> raise (Omake_value_type.OmakeException (loc_exp_pos loc, StringStringError ("illegal field name", method_id_string name))) in body, e ) # 1364 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'other_id_target) in let _2 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 436 "omake_ast_parse.mly" ( let e, loc = _1 in NoBody, ShellExp (e, loc) ) # 1374 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'other_target) in let _2 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 440 "omake_ast_parse.mly" ( let e, loc = _1 in NoBody, ShellExp (e, loc) ) # 1384 "omake_ast_parse.ml" : 'shell_line)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_deps) in let _2 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 450 "omake_ast_parse.mly" ( List.rev _1 ) # 1392 "omake_ast_parse.ml" : (Omake_ast.exp * Omake_ast.exp * Lm_location.t) list)) ; (fun __caml_parser_env -> Obj.repr( # 455 "omake_ast_parse.mly" ( [] ) # 1398 "omake_ast_parse.ml" : 'rev_deps)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_deps) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'dep) in Obj.repr( # 457 "omake_ast_parse.mly" ( _2 :: _1 ) # 1406 "omake_ast_parse.ml" : 'rev_deps)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_deps) in let _2 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 459 "omake_ast_parse.mly" ( _1 ) # 1414 "omake_ast_parse.ml" : 'rev_deps)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'target) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'target) in let _4 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 464 "omake_ast_parse.mly" ( let _, loc2 = _2 in let target, loc1 = match _1 with Some (e, loc1) -> e, loc1 | None -> NullExp loc2, loc2 in let source = match _3 with Some (e, _) -> e | None -> NullExp loc2 in let loc = Lm_location.union_loc loc1 _4 in target, source, loc ) # 1438 "omake_ast_parse.ml" : 'dep)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 6 : string * Omake_ast.apply_strategy * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 5 : 'opt_white) in let _3 = (Parsing.peek_val __caml_parser_env 4 : string * Lm_location.t) in let _4 = (Parsing.peek_val __caml_parser_env 3 : 'opt_white) in let _5 = (Parsing.peek_val __caml_parser_env 2 : 'method_name) in let _6 = (Parsing.peek_val __caml_parser_env 1 : 'opt_apply_args) in let _7 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 485 "omake_ast_parse.mly" ( let _, strategy, loc1 = _1 in let _, loc2 = _7 in let idl, _ = _5 in let args = args_of_parse_args _6 in let loc = Lm_location.union_loc loc1 loc2 in match idl with [id] -> Omake_ast.ApplyExp (strategy, Lm_symbol.add id, args, loc), loc | _ -> MethodApplyExp (strategy, method_id_intern idl, args, loc), loc ) # 1461 "omake_ast_parse.ml" : 'apply)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 8 : string * Omake_ast.apply_strategy * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 7 : 'opt_white) in let _3 = (Parsing.peek_val __caml_parser_env 6 : string * Lm_location.t) in let _4 = (Parsing.peek_val __caml_parser_env 5 : 'opt_white) in let _5 = (Parsing.peek_val __caml_parser_env 4 : 'id) in let _6 = (Parsing.peek_val __caml_parser_env 3 : string * Lm_location.t) in let _7 = (Parsing.peek_val __caml_parser_env 2 : 'id) in let _8 = (Parsing.peek_val __caml_parser_env 1 : 'opt_apply_args) in let _9 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 497 "omake_ast_parse.mly" ( let _, strategy, loc1 = _1 in let _, loc2 = _9 in let super, _ = _5 in let v, _ = _7 in let args = args_of_parse_args _8 in let loc = Lm_location.union_loc loc1 loc2 in SuperApplyExp (strategy, Lm_symbol.add super, Lm_symbol.add v, args, loc), loc ) # 1483 "omake_ast_parse.ml" : 'apply)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.apply_strategy * string * Lm_location.t) in Obj.repr( # 506 "omake_ast_parse.mly" ( let strategy, id, loc = _1 in ApplyExp (strategy, Lm_symbol.add id, [], loc), loc ) # 1492 "omake_ast_parse.ml" : 'apply)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : 'rev_text) in let _3 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 510 "omake_ast_parse.mly" ( let id1, loc1 = _1 in let id2, loc2 = _3 in let loc = Lm_location.union_loc loc1 loc2 in let el = Omake_ast.StringOtherExp (id1, loc1) :: List.rev_append _2 [ Omake_ast.StringOtherExp (id2, loc2)] in QuoteExp (el, loc), loc ) # 1507 "omake_ast_parse.ml" : 'apply)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : 'rev_text) in let _3 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 518 "omake_ast_parse.mly" ( let id, loc1 = _1 in let _, loc2 = _3 in let loc = Lm_location.union_loc loc1 loc2 in QuoteStringExp (id.[0], List.rev _2, loc), loc ) # 1520 "omake_ast_parse.ml" : 'apply)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 524 "omake_ast_parse.mly" ( let s, loc = _1 in QuoteExp ([StringOtherExp (s, loc)], loc), loc ) # 1529 "omake_ast_parse.ml" : 'apply)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'var_quote) in Obj.repr( # 534 "omake_ast_parse.mly" ( _1 ) # 1536 "omake_ast_parse.ml" : 'var_quote_opt_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'var_quote_white) in Obj.repr( # 536 "omake_ast_parse.mly" ( let strategy, id, _, loc = _1 in strategy, id, loc ) # 1545 "omake_ast_parse.ml" : 'var_quote_opt_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'var_quote) in let _2 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 543 "omake_ast_parse.mly" ( let strategy, id, loc = _1 in let s, _ = _2 in strategy, id, s, loc ) # 1556 "omake_ast_parse.ml" : 'var_quote_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.apply_strategy * string * Lm_location.t) in Obj.repr( # 551 "omake_ast_parse.mly" ( _1 ) # 1563 "omake_ast_parse.ml" : 'var_quote)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'var_quote_opt_white) in Obj.repr( # 559 "omake_ast_parse.mly" ( var_quote _1 ) # 1570 "omake_ast_parse.ml" : 'quote_opt_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'var_quote_white) in Obj.repr( # 564 "omake_ast_parse.mly" ( let strategy, id, s, loc = _1 in let e, _ = var_quote (strategy, id, loc) in e, s, loc ) # 1580 "omake_ast_parse.ml" : 'quote_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'var_quote) in Obj.repr( # 571 "omake_ast_parse.mly" ( var_quote _1 ) # 1587 "omake_ast_parse.ml" : 'quote)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_method_name) in Obj.repr( # 579 "omake_ast_parse.mly" ( let idl, loc = _1 in List.rev idl, loc ) # 1596 "omake_ast_parse.ml" : 'method_name)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'id) in Obj.repr( # 586 "omake_ast_parse.mly" ( let id, loc = _1 in [id], loc ) # 1605 "omake_ast_parse.ml" : 'rev_method_name)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'rev_method_name) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'id) in Obj.repr( # 590 "omake_ast_parse.mly" ( let idl, loc1 = _1 in let id, loc2 = _3 in id :: idl, Lm_location.union_loc loc1 loc2 ) # 1617 "omake_ast_parse.ml" : 'rev_method_name)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 597 "omake_ast_parse.mly" ( _1 ) # 1624 "omake_ast_parse.ml" : 'id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 599 "omake_ast_parse.mly" ( _1 ) # 1631 "omake_ast_parse.ml" : 'id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 601 "omake_ast_parse.mly" ( _1 ) # 1638 "omake_ast_parse.ml" : 'id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 603 "omake_ast_parse.mly" ( _1 ) # 1645 "omake_ast_parse.ml" : 'id)) ; (fun __caml_parser_env -> Obj.repr( # 608 "omake_ast_parse.mly" ( [] ) # 1651 "omake_ast_parse.ml" : 'opt_id_list)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'opt_id_list) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'white) in Obj.repr( # 610 "omake_ast_parse.mly" ( _1 ) # 1659 "omake_ast_parse.ml" : 'opt_id_list)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'opt_id_list) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'id) in Obj.repr( # 612 "omake_ast_parse.mly" ( let id, _ = _2 in id :: _1 ) # 1669 "omake_ast_parse.ml" : 'opt_id_list)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'method_id_opt_white) in Obj.repr( # 624 "omake_ast_parse.mly" ( let idl, loc = _1 in method_id_string_exp idl loc, loc ) # 1678 "omake_ast_parse.ml" : 'other_id_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'method_id_prefix_opt_white) in Obj.repr( # 628 "omake_ast_parse.mly" ( let idl, loc = _1 in method_id_prefix_string_exp idl loc, loc ) # 1687 "omake_ast_parse.ml" : 'other_id_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote_opt_white) in Obj.repr( # 632 "omake_ast_parse.mly" ( _1 ) # 1694 "omake_ast_parse.ml" : 'other_id_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_method_id) in Obj.repr( # 637 "omake_ast_parse.mly" ( let id, loc = _1 in List.rev id, loc ) # 1703 "omake_ast_parse.ml" : 'method_id_opt_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_method_id_white) in Obj.repr( # 641 "omake_ast_parse.mly" ( let id, _, loc = _1 in List.rev id, loc ) # 1712 "omake_ast_parse.ml" : 'method_id_opt_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_method_id_prefix) in Obj.repr( # 648 "omake_ast_parse.mly" ( let id, loc = _1 in List.rev id, loc ) # 1721 "omake_ast_parse.ml" : 'method_id_prefix_opt_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_method_id_prefix_white) in Obj.repr( # 652 "omake_ast_parse.mly" ( let id, _, loc = _1 in List.rev id, loc ) # 1730 "omake_ast_parse.ml" : 'method_id_prefix_opt_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_method_id) in let _2 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 659 "omake_ast_parse.mly" ( let id, loc1 = _1 in let s, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in id, s, loc ) # 1742 "omake_ast_parse.ml" : 'rev_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_method_id_prefix) in let _2 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 668 "omake_ast_parse.mly" ( let id, loc1 = _1 in let s, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in id, s, loc ) # 1754 "omake_ast_parse.ml" : 'rev_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 677 "omake_ast_parse.mly" ( let id, loc = _1 in [id], loc ) # 1763 "omake_ast_parse.ml" : 'rev_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_method_id_prefix) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'id) in Obj.repr( # 681 "omake_ast_parse.mly" ( let idl, loc1 = _1 in let id, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in id :: idl, loc ) # 1775 "omake_ast_parse.ml" : 'rev_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_method_id) in let _2 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 690 "omake_ast_parse.mly" ( let idl, loc1 = _1 in let _, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in idl, loc ) # 1787 "omake_ast_parse.ml" : 'rev_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 696 "omake_ast_parse.mly" ( let id, loc1 = _1 in let _, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in [id], loc ) # 1799 "omake_ast_parse.ml" : 'rev_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 702 "omake_ast_parse.mly" ( let id, loc1 = _1 in let _, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in [id], loc ) # 1811 "omake_ast_parse.ml" : 'rev_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 708 "omake_ast_parse.mly" ( let id, loc1 = _1 in let _, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in [id], loc ) # 1823 "omake_ast_parse.ml" : 'rev_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_other_target) in Obj.repr( # 737 "omake_ast_parse.mly" ( let l, loc = _1 in sequence_exp (List.rev l) loc, loc ) # 1832 "omake_ast_parse.ml" : 'other_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'other_start) in Obj.repr( # 744 "omake_ast_parse.mly" ( let e, loc = _1 in [e], loc ) # 1841 "omake_ast_parse.ml" : 'rev_other_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_method_id) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'other_method_id) in Obj.repr( # 748 "omake_ast_parse.mly" ( let idl, loc1 = _1 in let e, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in let el = [e; method_id_string_exp (List.rev idl) loc1] in el, loc ) # 1854 "omake_ast_parse.ml" : 'rev_other_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_method_id_white) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'other_method_id_white) in Obj.repr( # 755 "omake_ast_parse.mly" ( let idl, s, loc1 = _1 in let e, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in let el = [e; Omake_ast.StringWhiteExp (s, loc1); method_id_string_exp (List.rev idl) loc1] in el, loc ) # 1867 "omake_ast_parse.ml" : 'rev_other_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_method_id_prefix) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'other_method_id_prefix) in Obj.repr( # 762 "omake_ast_parse.mly" ( let idl, loc1 = _1 in let e, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in let el = [e; method_id_prefix_string_exp (List.rev idl) loc1] in el, loc ) # 1880 "omake_ast_parse.ml" : 'rev_other_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_method_id_prefix_white) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'other_method_id_prefix_white) in Obj.repr( # 769 "omake_ast_parse.mly" ( let idl, s, loc1 = _1 in let e, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in let el = [e; Omake_ast.StringWhiteExp (s, loc1); method_id_prefix_string_exp (List.rev idl) loc1] in el, loc ) # 1893 "omake_ast_parse.ml" : 'rev_other_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'quote) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'other_quote_id) in Obj.repr( # 776 "omake_ast_parse.mly" ( let id, loc1 = _1 in let e, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in let el = [id; e] in el, loc ) # 1906 "omake_ast_parse.ml" : 'rev_other_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'quote_white) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'other_quote_id_white) in Obj.repr( # 783 "omake_ast_parse.mly" ( let id, s, loc1 = _1 in let e, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in let el = [id; StringWhiteExp (s, loc1); e] in el, loc ) # 1919 "omake_ast_parse.ml" : 'rev_other_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_other_target) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'target_next) in Obj.repr( # 790 "omake_ast_parse.mly" ( let el, loc1 = _1 in let e, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in e :: el, loc ) # 1931 "omake_ast_parse.ml" : 'rev_other_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'target) in Obj.repr( # 802 "omake_ast_parse.mly" ( match _1 with Some (e, _) -> Lm_symbol.SymbolTable.add Lm_symbol.SymbolTable.empty Omake_symbol.normal_sym e | None -> Lm_symbol.SymbolTable.empty ) # 1943 "omake_ast_parse.ml" : 'source)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'source) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'target) in Obj.repr( # 809 "omake_ast_parse.mly" ( let table = _1 in let name, _ = _2 in match _3 with Some (e, _) -> Lm_symbol.SymbolTable.add table (Lm_symbol.add name) e | None -> table ) # 1959 "omake_ast_parse.ml" : 'source)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'source_target) in Obj.repr( # 824 "omake_ast_parse.mly" ( match _1 with Some (e, _) -> Lm_symbol.SymbolTable.add Lm_symbol.SymbolTable.empty Omake_symbol.normal_sym e | None -> Lm_symbol.SymbolTable.empty ) # 1971 "omake_ast_parse.ml" : 'source_nonapply)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'source_nonapply) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'target) in Obj.repr( # 831 "omake_ast_parse.mly" ( let table = _1 in let name, _ = _2 in match _3 with Some (e, _) -> Lm_symbol.SymbolTable.add table (Lm_symbol.add name) e | None -> table ) # 1987 "omake_ast_parse.ml" : 'source_nonapply)) ; (fun __caml_parser_env -> Obj.repr( # 843 "omake_ast_parse.mly" ( None ) # 1993 "omake_ast_parse.ml" : 'source_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'other_id_target) in Obj.repr( # 845 "omake_ast_parse.mly" ( Some _1 ) # 2000 "omake_ast_parse.ml" : 'source_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'other_target) in Obj.repr( # 847 "omake_ast_parse.mly" ( Some _1 ) # 2007 "omake_ast_parse.ml" : 'source_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_text) in Obj.repr( # 861 "omake_ast_parse.mly" ( List.rev _1 ) # 2014 "omake_ast_parse.ml" : 'text)) ; (fun __caml_parser_env -> Obj.repr( # 866 "omake_ast_parse.mly" ( [] ) # 2020 "omake_ast_parse.ml" : 'rev_text)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_text) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'text_next) in Obj.repr( # 868 "omake_ast_parse.mly" ( let e, _ = _2 in e :: _1 ) # 2030 "omake_ast_parse.ml" : 'rev_text)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'opt_white) in Obj.repr( # 881 "omake_ast_parse.mly" ( None ) # 2037 "omake_ast_parse.ml" : 'target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'rev_target) in Obj.repr( # 883 "omake_ast_parse.mly" ( let l, loc = _2 in Some (sequence_exp (List.rev l) loc, loc) ) # 2047 "omake_ast_parse.ml" : 'target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'target_start) in Obj.repr( # 890 "omake_ast_parse.mly" ( let e, loc = _1 in [e], loc ) # 2056 "omake_ast_parse.ml" : 'rev_target)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_target) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'target_next) in Obj.repr( # 894 "omake_ast_parse.mly" ( let l, loc1 = _1 in let e, loc2 = _2 in e :: l, Lm_location.union_loc loc1 loc2 ) # 2067 "omake_ast_parse.ml" : 'rev_target)) ; (fun __caml_parser_env -> Obj.repr( # 907 "omake_ast_parse.mly" ( None ) # 2073 "omake_ast_parse.ml" : 'keyword_text_optcolon)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_keyword_text) in Obj.repr( # 909 "omake_ast_parse.mly" ( let code, _, el, loc = _1 in Some (code, sequence_exp (List.rev el) loc) ) # 2082 "omake_ast_parse.ml" : 'keyword_text_optcolon)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'keyword_target_start) in Obj.repr( # 916 "omake_ast_parse.mly" ( let e, loc = _1 in OptBody, [], [e], loc ) # 2091 "omake_ast_parse.ml" : 'rev_keyword_text)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'colon) in Obj.repr( # 920 "omake_ast_parse.mly" ( let e, loc = _1 in ColonBody, [e], [], loc ) # 2100 "omake_ast_parse.ml" : 'rev_keyword_text)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_keyword_text) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'white) in Obj.repr( # 924 "omake_ast_parse.mly" ( let code, final, prefix, loc1 = _1 in let e, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in code, e :: final, prefix, loc ) # 2112 "omake_ast_parse.ml" : 'rev_keyword_text)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_keyword_text) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'target_start) in Obj.repr( # 930 "omake_ast_parse.mly" ( let _, final, prefix, loc1 = _1 in let e, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in OptBody, [], e :: (final @ prefix), loc ) # 2124 "omake_ast_parse.ml" : 'rev_keyword_text)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_keyword_text) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'colon) in Obj.repr( # 936 "omake_ast_parse.mly" ( let _, final, prefix, loc1 = _1 in let e, loc2 = _2 in let loc = Lm_location.union_loc loc1 loc2 in ColonBody, [e], final @ prefix, loc ) # 2136 "omake_ast_parse.ml" : 'rev_keyword_text)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_text_nonempty) in Obj.repr( # 948 "omake_ast_parse.mly" ( let l, loc = _1 in sequence_exp (List.rev l) loc ) # 2145 "omake_ast_parse.ml" : 'text_nonempty)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'text_nonwhite) in Obj.repr( # 955 "omake_ast_parse.mly" ( let e, loc = _1 in [e], loc ) # 2154 "omake_ast_parse.ml" : 'rev_text_nonempty)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_text_nonempty) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'text_next) in Obj.repr( # 959 "omake_ast_parse.mly" ( let l, loc1 = _1 in let e, loc2 = _2 in e :: l, Lm_location.union_loc loc1 loc2 ) # 2165 "omake_ast_parse.ml" : 'rev_text_nonempty)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'opt_white) in Obj.repr( # 970 "omake_ast_parse.mly" ( [] ) # 2172 "omake_ast_parse.ml" : 'opt_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'args) in Obj.repr( # 972 "omake_ast_parse.mly" ( _1 ) # 2179 "omake_ast_parse.ml" : 'opt_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'opt_white) in Obj.repr( # 977 "omake_ast_parse.mly" ( [] ) # 2186 "omake_ast_parse.ml" : 'opt_apply_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'white) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'args) in Obj.repr( # 979 "omake_ast_parse.mly" ( _2 ) # 2194 "omake_ast_parse.ml" : 'opt_apply_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_args) in Obj.repr( # 983 "omake_ast_parse.mly" ( List.rev _1 ) # 2201 "omake_ast_parse.ml" : 'args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_arrow_args) in Obj.repr( # 985 "omake_ast_parse.mly" ( List.rev _1 ) # 2208 "omake_ast_parse.ml" : 'args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'rev_arrow_args) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'rev_args) in Obj.repr( # 987 "omake_ast_parse.mly" ( List.rev_append _1 (List.rev _3) ) # 2217 "omake_ast_parse.ml" : 'args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arrow_arg) in Obj.repr( # 992 "omake_ast_parse.mly" ( [_1] ) # 2224 "omake_ast_parse.ml" : 'rev_arrow_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'rev_arrow_args) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arrow_arg) in Obj.repr( # 994 "omake_ast_parse.mly" ( _3 :: _1 ) # 2233 "omake_ast_parse.ml" : 'rev_arrow_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'rev_args) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_white) in let _4 = (Parsing.peek_val __caml_parser_env 0 : 'rev_any_arg) in Obj.repr( # 999 "omake_ast_parse.mly" ( let el, loc2 = _4 in NormalArg (ArrowArg (get_fun_params (List.rev _1), sequence_exp (List.rev el) loc2)) ) # 2245 "omake_ast_parse.ml" : 'arrow_arg)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arg) in Obj.repr( # 1006 "omake_ast_parse.mly" ( [_1] ) # 2252 "omake_ast_parse.ml" : 'rev_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'rev_args) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arg) in Obj.repr( # 1008 "omake_ast_parse.mly" ( _3 :: _1 ) # 2261 "omake_ast_parse.ml" : 'rev_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'arg_inner) in Obj.repr( # 1012 "omake_ast_parse.mly" ( _2 ) # 2269 "omake_ast_parse.ml" : 'arg)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_normal_arg) in Obj.repr( # 1017 "omake_ast_parse.mly" ( let el, loc = _1 in let e = sequence_exp (List.rev el) loc in NormalArg (ExpArg e) ) # 2279 "omake_ast_parse.ml" : 'arg_inner)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arg_id) in Obj.repr( # 1022 "omake_ast_parse.mly" ( let (id, _), w, loc = _1 in IdArg (id, w, loc) ) # 2288 "omake_ast_parse.ml" : 'arg_inner)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arg_key) in Obj.repr( # 1026 "omake_ast_parse.mly" ( let (id, _), w, loc = _1 in IdArg (id, w, loc) ) # 2297 "omake_ast_parse.ml" : 'arg_inner)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arg_key) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'opt_white) in Obj.repr( # 1030 "omake_ast_parse.mly" ( let (id, _), _, loc1 = _1 in let key = key_of_id id in NormalArg (KeyArg (key, NullExp loc1)) ) # 2309 "omake_ast_parse.ml" : 'arg_inner)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'arg_key) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_white) in let _4 = (Parsing.peek_val __caml_parser_env 0 : 'rev_any_arg) in Obj.repr( # 1035 "omake_ast_parse.mly" ( let (id, _), _, _ = _1 in let key = key_of_id id in let el, loc2 = _4 in NormalArg (KeyArg (key, sequence_exp (List.rev el) loc2)) ) # 2323 "omake_ast_parse.ml" : 'arg_inner)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'id) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'opt_white) in Obj.repr( # 1043 "omake_ast_parse.mly" ( let id = _1 in let _, loc = id in id, _2, loc ) # 2334 "omake_ast_parse.ml" : 'arg_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'opt_white) in Obj.repr( # 1051 "omake_ast_parse.mly" ( let id = _1 in let _, loc = id in id, _2, loc ) # 2345 "omake_ast_parse.ml" : 'arg_key)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'paren_arg_any_start) in Obj.repr( # 1059 "omake_ast_parse.mly" ( let e, loc = _1 in [e], loc ) # 2354 "omake_ast_parse.ml" : 'rev_any_arg)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_any_arg) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'paren_arg_next) in Obj.repr( # 1063 "omake_ast_parse.mly" ( let l, loc1 = _1 in let e, loc2 = _2 in e :: l, Lm_location.union_loc loc1 loc2 ) # 2365 "omake_ast_parse.ml" : 'rev_any_arg)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'arg_key) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'paren_arg_next_noneq) in Obj.repr( # 1071 "omake_ast_parse.mly" ( let (id, loc0), w, loc1 = _1 in let id = Omake_ast.StringIdExp (id, loc0) in let e, loc2 = _2 in let el = match w with Some (w, loc0) -> [e; Omake_ast.StringWhiteExp (w, loc0); id] | None -> [e; id] in el, Lm_location.union_loc loc1 loc2 ) # 2384 "omake_ast_parse.ml" : 'rev_normal_arg)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'arg_id) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'paren_arg_any_start) in Obj.repr( # 1084 "omake_ast_parse.mly" ( let (id, loc0), w, loc1 = _1 in let id = Omake_ast.StringIdExp (id, loc0) in let e, loc2 = _2 in let el = match w with Some (w, loc3) -> [e; StringWhiteExp (w, loc3); id] | None -> [e; id] in el, Lm_location.union_loc loc1 loc2 ) # 2403 "omake_ast_parse.ml" : 'rev_normal_arg)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'paren_arg_start) in Obj.repr( # 1097 "omake_ast_parse.mly" ( let e, loc = _1 in [e], loc ) # 2412 "omake_ast_parse.ml" : 'rev_normal_arg)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_normal_arg) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'paren_arg_next) in Obj.repr( # 1101 "omake_ast_parse.mly" ( let l, loc1 = _1 in let e, loc2 = _2 in e :: l, Lm_location.union_loc loc1 loc2 ) # 2423 "omake_ast_parse.ml" : 'rev_normal_arg)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arg_any_start) in Obj.repr( # 1109 "omake_ast_parse.mly" ( _1 ) # 2430 "omake_ast_parse.ml" : 'paren_arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'paren_arg) in Obj.repr( # 1111 "omake_ast_parse.mly" ( _1 ) # 2437 "omake_ast_parse.ml" : 'paren_arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arg_next_noneq) in Obj.repr( # 1116 "omake_ast_parse.mly" ( _1 ) # 2444 "omake_ast_parse.ml" : 'paren_arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'paren_arg) in Obj.repr( # 1118 "omake_ast_parse.mly" ( _1 ) # 2451 "omake_ast_parse.ml" : 'paren_arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arg_start) in Obj.repr( # 1123 "omake_ast_parse.mly" ( _1 ) # 2458 "omake_ast_parse.ml" : 'paren_arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'paren_arg) in Obj.repr( # 1125 "omake_ast_parse.mly" ( _1 ) # 2465 "omake_ast_parse.ml" : 'paren_arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arg_next) in Obj.repr( # 1130 "omake_ast_parse.mly" ( _1 ) # 2472 "omake_ast_parse.ml" : 'paren_arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'paren_arg) in Obj.repr( # 1132 "omake_ast_parse.mly" ( _1 ) # 2479 "omake_ast_parse.ml" : 'paren_arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : 'rev_paren_text) in let _3 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1137 "omake_ast_parse.mly" ( let s1, loc1 = _1 in let sl = _2 in let s3, loc3 = _3 in let loc = Lm_location.union_loc loc1 loc3 in let el = Omake_ast.StringOpExp (s1, loc1) :: (List.rev (Omake_ast.StringOpExp (s3, loc3) :: sl)) in SequenceExp (el, loc), loc ) # 2494 "omake_ast_parse.ml" : 'paren_arg)) ; (fun __caml_parser_env -> Obj.repr( # 1148 "omake_ast_parse.mly" ( [] ) # 2500 "omake_ast_parse.ml" : 'rev_paren_text)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_paren_text) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'paren_next) in Obj.repr( # 1150 "omake_ast_parse.mly" ( let s, _ = _2 in s :: _1 ) # 2510 "omake_ast_parse.ml" : 'rev_paren_text)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_paren_text) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'paren_arg) in Obj.repr( # 1154 "omake_ast_parse.mly" ( let s, _ = _2 in s :: _1 ) # 2520 "omake_ast_parse.ml" : 'rev_paren_text)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1164 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2527 "omake_ast_parse.ml" : 'colon)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1166 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2534 "omake_ast_parse.ml" : 'colon)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1168 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2541 "omake_ast_parse.ml" : 'colon)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1172 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringWhiteExp (s, loc), loc ) # 2548 "omake_ast_parse.ml" : 'white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1176 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringWhiteExp (s, loc), loc ) # 2555 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1178 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2562 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1180 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2569 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1182 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2576 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1184 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2583 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1186 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2590 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1188 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2597 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1190 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2604 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1192 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2611 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1194 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2618 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1196 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2625 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1198 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2632 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1200 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 2639 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1202 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 2646 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1204 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 2653 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1206 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 2660 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1208 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 2667 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1210 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 2674 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1212 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 2681 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1214 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 2688 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1216 "omake_ast_parse.mly" ( _1 ) # 2695 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1218 "omake_ast_parse.mly" ( _1 ) # 2702 "omake_ast_parse.ml" : 'text_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1222 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2709 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1224 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2716 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1226 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2723 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1228 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2730 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1230 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2737 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1232 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2744 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1234 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2751 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1236 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2758 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1238 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2765 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1240 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2772 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1242 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2779 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1244 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 2786 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1246 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 2793 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1248 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 2800 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1250 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 2807 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1252 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 2814 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1254 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 2821 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1256 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 2828 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1258 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 2835 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1260 "omake_ast_parse.mly" ( _1 ) # 2842 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1262 "omake_ast_parse.mly" ( _1 ) # 2849 "omake_ast_parse.ml" : 'text_nonwhite)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1266 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringWhiteExp (s, loc), loc ) # 2856 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1268 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2863 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1270 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2870 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1272 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2877 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1274 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2884 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1276 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2891 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1278 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2898 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1280 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2905 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1282 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2912 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1284 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 2919 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1286 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 2926 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1288 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 2933 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1290 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 2940 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1292 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 2947 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1294 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 2954 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1296 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 2961 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1298 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 2968 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1300 "omake_ast_parse.mly" ( _1 ) # 2975 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1302 "omake_ast_parse.mly" ( _1 ) # 2982 "omake_ast_parse.ml" : 'target_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1306 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2989 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1308 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 2996 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1310 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3003 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1312 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3010 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1314 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3017 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1316 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3024 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1318 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3031 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1320 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3038 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1322 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 3045 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1324 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 3052 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1326 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 3059 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1328 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3066 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1330 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3073 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1332 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3080 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1334 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3087 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1336 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 3094 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1338 "omake_ast_parse.mly" ( _1 ) # 3101 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1340 "omake_ast_parse.mly" ( _1 ) # 3108 "omake_ast_parse.ml" : 'target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1344 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3115 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1346 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3122 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1348 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3129 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1350 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3136 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1352 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3143 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1354 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3150 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1356 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3157 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1358 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 3164 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1360 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 3171 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1362 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 3178 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1364 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3185 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1366 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3192 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1368 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3199 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1370 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3206 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1372 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 3213 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1374 "omake_ast_parse.mly" ( _1 ) # 3220 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1376 "omake_ast_parse.mly" ( _1 ) # 3227 "omake_ast_parse.ml" : 'keyword_target_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1380 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringWhiteExp (s, loc), loc ) # 3234 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1382 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3241 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1384 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3248 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1386 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3255 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1388 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3262 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1390 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3269 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1392 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3276 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1394 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3283 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1396 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3290 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1398 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3297 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1400 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 3304 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1402 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 3311 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1404 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 3318 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1406 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3325 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1408 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3332 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1410 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3339 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1412 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3346 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1414 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 3353 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1416 "omake_ast_parse.mly" ( _1 ) # 3360 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1418 "omake_ast_parse.mly" ( _1 ) # 3367 "omake_ast_parse.ml" : 'paren_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1422 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringWhiteExp (s, loc), loc ) # 3374 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1424 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3381 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1426 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3388 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1428 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3395 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1430 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3402 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1432 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3409 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1434 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3416 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1436 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3423 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1438 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 3430 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1440 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 3437 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1442 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 3444 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1444 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3451 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1446 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3458 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1448 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3465 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1450 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3472 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1452 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 3479 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1454 "omake_ast_parse.mly" ( _1 ) # 3486 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1456 "omake_ast_parse.mly" ( _1 ) # 3493 "omake_ast_parse.ml" : 'arg_next)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1460 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3500 "omake_ast_parse.ml" : 'arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1462 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3507 "omake_ast_parse.ml" : 'arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1464 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3514 "omake_ast_parse.ml" : 'arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1466 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3521 "omake_ast_parse.ml" : 'arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1468 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3528 "omake_ast_parse.ml" : 'arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1470 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3535 "omake_ast_parse.ml" : 'arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1472 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3542 "omake_ast_parse.ml" : 'arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1474 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 3549 "omake_ast_parse.ml" : 'arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1476 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 3556 "omake_ast_parse.ml" : 'arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1478 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 3563 "omake_ast_parse.ml" : 'arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1480 "omake_ast_parse.mly" ( _1 ) # 3570 "omake_ast_parse.ml" : 'arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1482 "omake_ast_parse.mly" ( _1 ) # 3577 "omake_ast_parse.ml" : 'arg_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1486 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3584 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1488 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3591 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1490 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3598 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1492 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3605 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1494 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3612 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1496 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3619 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1498 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3626 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1500 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 3633 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1502 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 3640 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1504 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 3647 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1506 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3654 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1508 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3661 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1510 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3668 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1512 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3675 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1514 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 3682 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1516 "omake_ast_parse.mly" ( _1 ) # 3689 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1518 "omake_ast_parse.mly" ( _1 ) # 3696 "omake_ast_parse.ml" : 'arg_any_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1522 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3703 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1524 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3710 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1526 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3717 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1528 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3724 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1530 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3731 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1532 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3738 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1534 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 3745 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1536 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 3752 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1538 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 3759 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1540 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3766 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1542 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3773 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1544 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3780 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1546 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3787 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1548 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 3794 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1550 "omake_ast_parse.mly" ( _1 ) # 3801 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1552 "omake_ast_parse.mly" ( _1 ) # 3808 "omake_ast_parse.ml" : 'arg_next_noneq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1556 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3815 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1558 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3822 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1560 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3829 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1562 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3836 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1564 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3843 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1566 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3850 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1568 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3857 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1570 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3864 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1572 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 3871 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1574 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 3878 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1576 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3885 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1578 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 3892 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1580 "omake_ast_parse.mly" ( _1 ) # 3899 "omake_ast_parse.ml" : 'other_start)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1584 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringWhiteExp (s, loc), loc ) # 3906 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1586 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3913 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1588 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3920 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1590 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3927 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1592 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3934 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1594 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 3941 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1596 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 3948 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1598 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 3955 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1600 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 3962 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1602 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3969 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1604 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3976 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1606 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3983 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1608 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 3990 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1610 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 3997 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1612 "omake_ast_parse.mly" ( _1 ) # 4004 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1614 "omake_ast_parse.mly" ( _1 ) # 4011 "omake_ast_parse.ml" : 'other_method_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1618 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4018 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1620 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4025 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1622 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4032 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1624 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4039 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1626 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 4046 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1628 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 4053 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1630 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 4060 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1632 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4067 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1634 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4074 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1636 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4081 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1638 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4088 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1640 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 4095 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1642 "omake_ast_parse.mly" ( _1 ) # 4102 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1644 "omake_ast_parse.mly" ( _1 ) # 4109 "omake_ast_parse.ml" : 'other_method_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1648 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringWhiteExp (s, loc), loc ) # 4116 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1650 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4123 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1652 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4130 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1654 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4137 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1656 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4144 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1658 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4151 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1660 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4158 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1662 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4165 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1664 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 4172 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1666 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 4179 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1668 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4186 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1670 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 4193 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1672 "omake_ast_parse.mly" ( _1 ) # 4200 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1674 "omake_ast_parse.mly" ( _1 ) # 4207 "omake_ast_parse.ml" : 'other_method_id_prefix_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1678 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4214 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1680 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4221 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1682 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4228 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1684 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4235 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1686 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4242 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1688 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4249 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1690 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4256 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1692 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 4263 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1694 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 4270 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1696 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4277 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1698 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 4284 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1700 "omake_ast_parse.mly" ( _1 ) # 4291 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1702 "omake_ast_parse.mly" ( _1 ) # 4298 "omake_ast_parse.ml" : 'other_method_id_prefix)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1706 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringWhiteExp (s, loc), loc ) # 4305 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1708 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4312 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1710 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4319 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1712 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4326 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1714 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4333 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1716 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4340 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1718 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4347 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1720 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4354 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1722 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 4361 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1724 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 4368 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1726 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 4375 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1728 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4382 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1730 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4389 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1732 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4396 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1734 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4403 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1736 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 4410 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1738 "omake_ast_parse.mly" ( _1 ) # 4417 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1740 "omake_ast_parse.mly" ( _1 ) # 4424 "omake_ast_parse.ml" : 'other_quote_id_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1744 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4431 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1746 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4438 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1748 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4445 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1750 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4452 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1752 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4459 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1754 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4466 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1756 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOpExp (s, loc), loc ) # 4473 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1758 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIdExp (s, loc), loc ) # 4480 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1760 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringIntExp (s, loc), loc ) # 4487 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1762 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringFloatExp (s, loc), loc ) # 4494 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1764 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4501 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1766 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4508 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1768 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4515 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1770 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringKeywordExp (s, loc), loc ) # 4522 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1772 "omake_ast_parse.mly" ( let (s, loc) = _1 in StringOtherExp (s, loc), loc ) # 4529 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'quote) in Obj.repr( # 1774 "omake_ast_parse.mly" ( _1 ) # 4536 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'apply) in Obj.repr( # 1776 "omake_ast_parse.mly" ( _1 ) # 4543 "omake_ast_parse.ml" : 'other_quote_id)) ; (fun __caml_parser_env -> Obj.repr( # 1784 "omake_ast_parse.mly" ( OptBody ) # 4549 "omake_ast_parse.ml" : 'opt_literal_colon)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'colon) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'opt_white) in Obj.repr( # 1786 "omake_ast_parse.mly" ( ColonBody ) # 4557 "omake_ast_parse.ml" : 'opt_literal_colon)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'opt_white) in Obj.repr( # 1791 "omake_ast_parse.mly" ( OptBody ) # 4564 "omake_ast_parse.ml" : 'opt_colon)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'opt_white) in let _2 = (Parsing.peek_val __caml_parser_env 1 : 'colon) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'opt_white) in Obj.repr( # 1793 "omake_ast_parse.mly" ( ColonBody ) # 4573 "omake_ast_parse.ml" : 'opt_colon)) ; (fun __caml_parser_env -> Obj.repr( # 1798 "omake_ast_parse.mly" ( None ) # 4579 "omake_ast_parse.ml" : 'opt_white)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 1800 "omake_ast_parse.mly" ( Some _1 ) # 4586 "omake_ast_parse.ml" : 'opt_white)) (* Entry deps *) ; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) (* Entry shell *) ; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) (* Entry string *) ; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) |] let yytables = { Parsing.actions=yyact; Parsing.transl_const=yytransl_const; Parsing.transl_block=yytransl_block; Parsing.lhs=yylhs; Parsing.len=yylen; Parsing.defred=yydefred; Parsing.dgoto=yydgoto; Parsing.sindex=yysindex; Parsing.rindex=yyrindex; Parsing.gindex=yygindex; Parsing.tablesize=yytablesize; Parsing.table=yytable; Parsing.check=yycheck; Parsing.error_function=parse_error; Parsing.names_const=yynames_const; Parsing.names_block=yynames_block } let deps (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = (Parsing.yyparse yytables 1 lexfun lexbuf : (Omake_ast.exp * Omake_ast.exp * Lm_location.t) list) let shell (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = (Parsing.yyparse yytables 2 lexfun lexbuf : Omake_ast.body_flag * Omake_ast.exp) let string (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = (Parsing.yyparse yytables 3 lexfun lexbuf : Omake_ast.body_flag * Omake_ast.exp) omake-0.10.3/src/env/omake_ir_semant.ml0000644000175000017500000003446113177364665016413 0ustar gerdgerd(* * Operations: * 1. Check that all return/export operations are in legal * places. * 2. Add final operations to sequences that don't already * have them. * 3. Add return handlers to functions that have nontrivial * return statements. *) include Omake_pos.Make (struct let name = "Omake_ir_semant" end) (* * Synthesized attributes. * renv_has_return : is there a non-tail return? * renv_is_final : code after this point is never executed *) type renv = { renv_has_return : bool; renv_is_final : bool; renv_is_value : bool } (* * Inherited attributes. * env_in_function : currently within a function body * env_in_cond : currently within a conditional * env_is_tail : the current expression is in final position *) type env = { env_warnings : Lm_location.t option ref; env_in_function : Omake_ir.return_id option; env_in_cond : bool; env_section_tail : bool; env_function_tail : bool } (* * Return environments. *) let renv_empty = { renv_has_return = false; renv_is_final = false; renv_is_value = false } let renv_value = { renv_has_return = false; renv_is_final = false; renv_is_value = true } let renv_final = { renv_has_return = false; renv_is_final = true; renv_is_value = true } let renv_return = { renv_has_return = true; renv_is_final = true; renv_is_value = true } (* * Normal environment, not in a function. *) let env_empty () = { env_warnings = ref None; env_in_function = None; env_in_cond = false; env_section_tail = false; env_function_tail = false } let env_object env = { env_warnings = env.env_warnings; env_in_function = None; env_in_cond = false; env_section_tail = false; env_function_tail = false } let env_object_tail env = { env_warnings = env.env_warnings; env_in_function = None; env_in_cond = false; env_section_tail = true; env_function_tail = true } (* * Fresh environment for a function body. *) let new_return_id loc v = let _, v = Omake_ir_util.var_of_var_info v in loc, Lm_symbol.to_string v let env_fun env id = { env_warnings = env.env_warnings; env_in_function = Some id; env_in_cond = false; env_section_tail = true; env_function_tail = true } let env_anon_fun env = { env with env_in_cond = true; env_section_tail = true } let update_return renv has_return = { renv with renv_has_return = renv.renv_has_return || has_return } (* * Error checkers. *) let check_return_placement env loc = match env.env_in_function with None -> let pos = string_pos "check_in_function" (loc_exp_pos loc) in let print_error buf = Format.fprintf buf "@[Misplaced return statement."; Format.fprintf buf "@ The return is not within a function.@]" in raise (Omake_value_type.OmakeException (pos, LazyError print_error)) | Some id -> if not (env.env_function_tail || env.env_section_tail && env.env_in_cond) then begin Lm_printf.eprintf "@[*** omake warning: %a@ statements after this return are not reached@]@." Lm_location.pp_print_location loc; env.env_warnings := Some loc end; id (* let check_section_tail env loc = *) (* if not env.env_section_tail then *) (* let pos = string_pos "check_section_tail" (loc_exp_pos loc) in *) (* raise (Omake_value_type.OmakeException (pos, StringError "This should be the last expression in the section.")) *) let check_object_tail env loc = if env.env_in_function <> None || not env.env_section_tail then let pos = string_pos "check_object_tail" (loc_exp_pos loc) in raise (Omake_value_type.OmakeException (pos, StringError "This should be the last expression in the object.")) (* * Convert a string expression. *) let rec build_string env s = let env = { env with env_function_tail = false } in match s with Omake_ir.NoneString _ | IntString _ | FloatString _ | WhiteString _ | ConstString _ | ThisString _ | KeyApplyString _ | VarString _ -> false, s | FunString (loc, opt_params, params, e, export) -> (* Returns propagate -through- anonymous functions *) let renv, e = build_sequence_exp (env_anon_fun env) e in let has_return, opt_params = build_keyword_param_list env opt_params in renv.renv_has_return || has_return, FunString (loc, opt_params, params, e, export) | ApplyString (loc, v, args, kargs) -> let has_return1, args = build_string_list env args in let has_return2, kargs = build_keyword_string_list env kargs in has_return1 || has_return2, ApplyString (loc, v, args, kargs) | SuperApplyString (loc, v1, v2, args, kargs) -> let has_return1, args = build_string_list env args in let has_return2, kargs = build_keyword_string_list env kargs in has_return1 || has_return2, SuperApplyString (loc, v1, v2, args, kargs) | MethodApplyString (loc, v, vl, args, kargs) -> let has_return1, args = build_string_list env args in let has_return2, kargs = build_keyword_string_list env kargs in has_return1 || has_return2, MethodApplyString (loc, v, vl, args, kargs) | SequenceString (loc, sl) -> let has_return, sl = build_string_list env sl in has_return, SequenceString (loc, sl) | ArrayString (loc, sl) -> let has_return, sl = build_string_list env sl in has_return, ArrayString (loc, sl) | ArrayOfString (loc, s) -> let has_return, s = build_string env s in has_return, ArrayOfString (loc, s) | QuoteString (loc, sl) -> let has_return, sl = build_string_list env sl in has_return, QuoteString (loc, sl) | QuoteStringString (loc, c, sl) -> let has_return, sl = build_string_list env sl in has_return, QuoteStringString (loc, c, sl) | ObjectString (loc, el, export) -> let el = build_object_exp env el in (* XXX: we should handle the case when an object contains a return *) false, ObjectString (loc, el, export) | BodyString (loc, el, export) -> let renv, el = build_sequence_exp env el in renv.renv_has_return, BodyString (loc, el, export) | ExpString (loc, el, export) -> let renv, el = build_sequence_exp env el in renv.renv_has_return, ExpString (loc, el, export) | CasesString (loc, cases) -> let env = { env with env_in_cond = true } in let has_return, cases = List.fold_left (fun (has_return, cases) (v, s, el, export) -> let has_return2, s = build_string env s in let renv, e = build_sequence_exp env el in let has_return = has_return || has_return2 || renv.renv_has_return in has_return, (v, s, e, export) :: cases) (false, []) cases in has_return, CasesString (loc, List.rev cases) | LazyString (loc, s) -> let has_return, s = build_string env s in has_return, LazyString (loc, s) | LetVarString (loc, v, s1, s2) -> let has_return1, s1 = build_string env s1 in let has_return2, s2 = build_string env s2 in has_return1 || has_return2, LetVarString (loc, v, s1, s2) and build_string_list env sl = let has_return, sl = List.fold_left (fun (has_return, sl) s -> let has_return2, s = build_string env s in has_return || has_return2, s :: sl) (false, []) sl in has_return, List.rev sl and build_keyword_string_list env kargs = let has_return, kargs = List.fold_left (fun (has_return, sl) (v, s) -> let has_return2, s = build_string env s in has_return || has_return2, (v, s) :: sl) (false, []) kargs in has_return, List.rev kargs and build_keyword_param_list env kargs = let has_return, kargs = List.fold_left (fun (has_return, sl) (v, v_info, s_opt) -> match s_opt with Some s -> let has_return2, s = build_string env s in has_return || has_return2, (v, v_info, Some s) :: sl | None -> has_return, (v, v_info, None) :: sl) (false, []) kargs in has_return, List.rev kargs (* * Convert the current expression. *) and build_exp env e = match e with Omake_ir.LetFunExp (loc, v, vl, curry, opt_params, vars, el, export) -> let id = new_return_id loc v in let renv, el = build_sequence_exp (env_fun env id) el in let el = if renv.renv_has_return then Omake_ir.[ReturnBodyExp (loc, el, id)] else el in let has_return, opt_params = build_keyword_param_list env opt_params in let e = Omake_ir.LetFunExp (loc, v, vl, curry, opt_params, vars, el, export) in update_return renv_empty has_return, e | LetObjectExp (loc, v, vl, s, el, export) -> let el = build_object_exp env el in let has_return, s = build_string env s in let e = Omake_ir.LetObjectExp (loc, v, vl, s, el, export) in update_return renv_empty has_return, e | StaticExp (loc, node, v, el) -> let el = build_object_exp env el in let e = Omake_ir.StaticExp (loc, node, v, el) in renv_empty, e | IfExp (loc, cases) -> let renv, cases = build_cases_exp env cases in let e = Omake_ir.IfExp (loc, cases) in renv, e | SequenceExp (loc, el) -> let renv, el = build_sequence_exp env el in let e = Omake_ir.SequenceExp (loc, el) in renv, e | SectionExp (loc, s, el, export) -> let has_return, s = build_string env s in let renv, el = build_sequence_exp env el in let e = Omake_ir.SectionExp (loc, s, el, export) in update_return renv has_return, e | ReturnBodyExp (loc, el, id) -> let renv, el = build_sequence_exp env el in let el = Omake_ir.ReturnBodyExp (loc, el, id) in renv, el | LetVarExp (loc, v, vl, kind, s) -> let has_return, s = build_string env s in let e = Omake_ir.LetVarExp (loc, v, vl, kind, s) in update_return renv_empty has_return, e | IncludeExp (loc, s, sl) -> let has_return1, s = build_string env s in let has_return2, sl = build_string_list env sl in let e = Omake_ir.IncludeExp (loc, s, sl) in update_return renv_empty (has_return1 || has_return2), e | ApplyExp (loc, v, args, kargs) -> let has_return1, args = build_string_list env args in let has_return2, kargs = build_keyword_string_list env kargs in let e = Omake_ir.ApplyExp (loc, v, args, kargs) in update_return renv_empty (has_return1 || has_return2), e | SuperApplyExp (loc, v1, v2, args, kargs) -> let has_return1, args = build_string_list env args in let has_return2, kargs = build_keyword_string_list env kargs in let e = Omake_ir.SuperApplyExp (loc, v1, v2, args, kargs) in update_return renv_empty (has_return1 || has_return2), e | MethodApplyExp (loc, v, vl, args, kargs) -> let has_return1, args = build_string_list env args in let has_return2, kargs = build_keyword_string_list env kargs in let e = Omake_ir.MethodApplyExp (loc, v, vl, args, kargs) in update_return renv_empty (has_return1 || has_return2), e | LetKeyExp (loc, v, kind, s) -> let has_return, s = build_string env s in let e = Omake_ir.LetKeyExp (loc, v, kind, s) in update_return renv_empty has_return, e | LetThisExp (loc, s) -> let has_return, s = build_string env s in let e = Omake_ir.LetThisExp (loc, s) in update_return renv_empty has_return, e | ShellExp (loc, s) -> let has_return, s = build_string env s in let e = Omake_ir.ShellExp (loc, s) in update_return renv_value has_return, e | KeyExp _ | OpenExp _ -> renv_empty, e | StringExp (loc, s) -> let has_return, s = build_string env s in let e = Omake_ir.StringExp (loc, s) in update_return renv_value has_return, e | ReturnExp (loc, s, _) -> let id = check_return_placement env loc in let has_return, s = build_string env s in if env.env_function_tail then update_return renv_final has_return, Omake_ir.StringExp (loc, s) else renv_return, Omake_ir.ReturnExp (loc, s, id) | ReturnObjectExp (loc, _) | ReturnSaveExp loc -> check_object_tail env loc; renv_final, e (* * An object expression is an expression sequence, * but it is not in a function. *) and build_object_exp_aux env el = match el with [e] -> let _, e = build_exp (env_object_tail env) e in [e] | e :: el -> let _, e = build_exp env e in let el = build_object_exp_aux env el in e :: el | [] -> [] and build_object_exp env el = build_object_exp_aux (env_object env) el (* * A new sequence expression. * It should be terminated with a final statement. *) and build_sequence_exp env el = let env_non_tail = { env with env_section_tail = false; env_function_tail = false } in let rec build_sequence_core has_return rel el = match el with [e] -> let env_tail = { env with env_section_tail = true } in let renv, e = build_exp env_tail e in let rel = e :: rel in update_return renv has_return, rel | e :: el -> let renv, e = build_exp env_non_tail e in let has_return = has_return || renv.renv_has_return in let rel = e :: rel in build_sequence_core has_return rel el | [] -> renv_empty, [] in let renv, rel = build_sequence_core false [] el in renv, List.rev rel (* * Cases are slightly different from sequences because * returns are always allowed. Note that the completeness is * not checked, so even if all cases end in a return, * evaluation may continue from here. *) and build_cases_exp env cases = let env = { env with env_in_cond = true; env_section_tail = true } in let has_return, cases = List.fold_left (fun (has_return, cases) (s, el, export) -> let renv, el = build_sequence_exp env el in let has_return = has_return || renv.renv_has_return in has_return, (s, el, export) :: cases) (false, []) cases in let cases = List.rev cases in let renv = { renv_is_final = false; renv_is_value = true; renv_has_return = has_return } in renv, cases (************************************************************************ * Main function *) let build_prog venv e = let env = env_empty () in let _, e = build_exp env e in let count = !(env.env_warnings) in let () = match count with |Some loc when Omake_options.opt_warn_error (Omake_env.venv_options venv) -> raise (Omake_value_type.OmakeException (loc_exp_pos loc, StringError "warnings treated as errors")) | _ -> () in e omake-0.10.3/src/env/omake_exp_parse.ml0000644000175000017500000012303613177364665016415 0ustar gerdgerdtype token = | TokEof | TokLeftParen of (Lm_location.t) | TokRightParen of (Lm_location.t) | TokLeftBrack of (Lm_location.t) | TokRightBrack of (Lm_location.t) | TokPlus of (Lm_location.t) | TokMinus of (Lm_location.t) | TokStar of (Lm_location.t) | TokSlash of (Lm_location.t) | TokMod of (Lm_location.t) | TokHat of (Lm_location.t) | TokPipe of (Lm_location.t) | TokAmp of (Lm_location.t) | TokLsl of (Lm_location.t) | TokLsr of (Lm_location.t) | TokAsr of (Lm_location.t) | TokAnd of (Lm_location.t) | TokOr of (Lm_location.t) | TokDot of (Lm_location.t) | TokComma of (Lm_location.t) | TokSemi of (Lm_location.t) | TokLe of (Lm_location.t) | TokLt of (Lm_location.t) | TokEq of (Lm_location.t) | TokNeq of (Lm_location.t) | TokGt of (Lm_location.t) | TokGe of (Lm_location.t) | TokColonColon of (Lm_location.t) | TokArrow of (Lm_location.t) | TokId of (Lm_symbol.t * Lm_location.t) | TokKey of (Lm_symbol.t * Lm_location.t) | TokCatch of (Lm_location.t) | TokInt of (int * Lm_location.t) | TokFloat of (float * Lm_location.t) | TokExp of (Omake_ast.exp) open Parsing;; let _ = parse_error;; # 26 "omake_exp_parse.mly" open Lm_location open Omake_ast open Omake_symbol open Omake_ast_util open Omake_value_type module Pos = Omake_pos.Make (struct let name = "Omake_exp_parse" end) open Pos;; (* * Different types of identifiers. *) type id = SimpleId of var | SuperId of var * var | MethodId of var list (* * Identifier stands for an application. *) let make_id_exp (id, loc) = let e = match id with SimpleId v -> ApplyExp (NormalApply, v, [], loc) | SuperId (v1, v2) -> SuperApplyExp (NormalApply, v1, v2, [], loc) | MethodId vars -> MethodApplyExp (NormalApply, vars, [], loc) in e, loc (* * Unary operations. *) let make_unary_exp v (e, loc) = ApplyExp (NormalApply, v, [ExpArg e], loc), loc let make_binary_exp v (e1, loc1) (e2, loc2) = let loc = union_loc loc1 loc2 in ApplyExp (NormalApply, v, [ExpArg e1; ExpArg e2], loc), loc (* * If the function is a null application, add the args. *) let apply_var = Lm_symbol.add ".fun" let make_apply_exp (e, loc) args = match e with ApplyExp (strategy, v, [], _) -> ApplyExp (strategy, v, args, loc), loc | _ -> (* Create a temporary private variable *) SequenceExp ([VarDefExp ([apply_var], DefineString, DefineNormal, e, loc); ApplyExp (NormalApply, apply_var, args, loc)], loc), loc (* * Function parameters from an argument list. *) let get_fun_param = function ExpArg (ApplyExp (NormalApply, v, [], loc)) -> NormalParam (v, loc) | ExpArg e | KeyArg (_, e) | ArrowArg (_, e) -> raise (OmakeException (loc_exp_pos (loc_of_exp e), StringError "illegal parameter")) let get_fun_params = List.map get_fun_param # 109 "omake_exp_parse.ml" let yytransl_const = [| 257 (* TokEof *); 0|] let yytransl_block = [| 258 (* TokLeftParen *); 259 (* TokRightParen *); 260 (* TokLeftBrack *); 261 (* TokRightBrack *); 262 (* TokPlus *); 263 (* TokMinus *); 264 (* TokStar *); 265 (* TokSlash *); 266 (* TokMod *); 267 (* TokHat *); 268 (* TokPipe *); 269 (* TokAmp *); 270 (* TokLsl *); 271 (* TokLsr *); 272 (* TokAsr *); 273 (* TokAnd *); 274 (* TokOr *); 275 (* TokDot *); 276 (* TokComma *); 277 (* TokSemi *); 278 (* TokLe *); 279 (* TokLt *); 280 (* TokEq *); 281 (* TokNeq *); 282 (* TokGt *); 283 (* TokGe *); 284 (* TokColonColon *); 285 (* TokArrow *); 286 (* TokId *); 287 (* TokKey *); 288 (* TokCatch *); 289 (* TokInt *); 290 (* TokFloat *); 291 (* TokExp *); 0|] let yylhs = "\255\255\ \001\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\003\000\003\000\003\000\ \006\000\006\000\005\000\005\000\007\000\007\000\008\000\008\000\ \009\000\009\000\004\000\004\000\010\000\010\000\010\000\012\000\ \012\000\013\000\011\000\011\000\014\000\014\000\014\000\000\000" let yylen = "\002\000\ \002\000\001\000\001\000\001\000\001\000\002\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\004\000\004\000\003\000\003\000\001\000\003\000\003\000\ \001\000\003\000\000\000\002\000\001\000\003\000\000\000\001\000\ \001\000\001\000\000\000\001\000\001\000\001\000\003\000\001\000\ \003\000\003\000\001\000\003\000\001\000\001\000\003\000\002\000" let yydefred = "\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\002\000\003\000\ \004\000\056\000\000\000\005\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\028\000\029\000\042\000\041\000\036\000\000\000\033\000\ \000\000\031\000\000\000\000\000\000\000\044\000\000\000\000\000\ \048\000\051\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\026\000\000\000\000\000\000\000\027\000\034\000\000\000\ \052\000\000\000\000\000\049\000" let yydgoto = "\002\000\ \010\000\052\000\012\000\053\000\015\000\049\000\016\000\046\000\ \047\000\054\000\055\000\056\000\057\000\058\000" let yysindex = "\010\000\ \051\255\000\000\051\255\051\255\051\255\242\254\000\000\000\000\ \000\000\000\000\103\001\000\000\129\001\181\001\007\255\245\254\ \004\255\239\254\241\254\000\000\040\255\051\255\051\255\051\255\ \051\255\051\255\051\255\051\255\051\255\051\255\051\255\051\255\ \051\255\051\255\051\255\051\255\051\255\051\255\051\255\051\255\ \051\255\000\000\000\000\000\000\000\000\000\000\051\255\000\000\ \000\255\000\000\249\254\181\001\017\255\000\000\243\254\023\255\ \000\000\000\000\155\001\243\000\243\000\004\255\004\255\004\255\ \029\002\233\001\003\002\084\001\084\001\084\001\207\001\207\001\ \081\002\081\002\055\002\055\002\081\002\081\002\181\001\015\255\ \051\255\000\000\040\255\051\255\040\255\000\000\000\000\181\001\ \000\000\181\001\243\254\000\000" let yyrindex = "\000\000\ \000\000\000\000\000\000\044\255\000\000\086\255\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\036\255\000\000\046\255\ \142\255\000\000\000\000\000\000\058\255\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\049\255\000\000\ \115\255\000\000\142\000\169\000\000\000\000\000\060\255\063\255\ \000\000\000\000\000\000\250\255\021\000\169\255\196\255\223\255\ \031\001\052\001\047\255\048\000\075\000\102\000\058\001\079\001\ \129\000\156\000\237\000\006\001\183\000\210\000\057\255\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\196\000\ \000\000\254\254\066\255\000\000" let yygindex = "\000\000\ \000\000\255\255\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\243\255\000\000\253\255\252\255" let yytablesize = 865 let yytable = "\011\000\ \050\000\013\000\014\000\017\000\018\000\021\000\083\000\022\000\ \044\000\045\000\001\000\043\000\048\000\019\000\050\000\084\000\ \081\000\050\000\080\000\082\000\059\000\060\000\061\000\062\000\ \063\000\064\000\065\000\066\000\067\000\068\000\069\000\070\000\ \071\000\072\000\073\000\074\000\075\000\076\000\077\000\078\000\ \037\000\003\000\085\000\004\000\087\000\079\000\005\000\014\000\ \035\000\014\000\039\000\014\000\003\000\040\000\004\000\037\000\ \037\000\005\000\014\000\014\000\043\000\038\000\045\000\014\000\ \014\000\046\000\014\000\014\000\047\000\006\000\051\000\091\000\ \007\000\008\000\009\000\014\000\038\000\038\000\089\000\088\000\ \006\000\092\000\090\000\007\000\008\000\009\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \000\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\000\000\030\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\000\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\006\000\032\000\ \006\000\000\000\006\000\006\000\006\000\006\000\006\000\006\000\ \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ \000\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ \006\000\009\000\006\000\009\000\000\000\009\000\009\000\009\000\ \009\000\009\000\009\000\009\000\009\000\009\000\009\000\009\000\ \009\000\009\000\009\000\000\000\009\000\009\000\009\000\009\000\ \009\000\009\000\009\000\009\000\010\000\009\000\010\000\000\000\ \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ \010\000\010\000\010\000\010\000\010\000\010\000\000\000\010\000\ \010\000\010\000\010\000\010\000\010\000\010\000\010\000\011\000\ \010\000\011\000\000\000\011\000\011\000\011\000\011\000\011\000\ \011\000\011\000\011\000\011\000\011\000\011\000\011\000\011\000\ \011\000\000\000\011\000\011\000\011\000\011\000\011\000\011\000\ \011\000\011\000\007\000\011\000\007\000\000\000\007\000\007\000\ \007\000\000\000\000\000\000\000\007\000\007\000\007\000\007\000\ \007\000\007\000\007\000\007\000\000\000\007\000\007\000\007\000\ \007\000\007\000\007\000\007\000\007\000\008\000\007\000\008\000\ \000\000\008\000\008\000\008\000\000\000\000\000\000\000\008\000\ \008\000\008\000\008\000\008\000\008\000\008\000\008\000\000\000\ \008\000\008\000\008\000\008\000\008\000\008\000\008\000\008\000\ \015\000\008\000\015\000\000\000\015\000\000\000\000\000\000\000\ \000\000\000\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\000\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\016\000\015\000\016\000\000\000\016\000\ \000\000\000\000\000\000\000\000\000\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\000\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\017\000\016\000\ \017\000\000\000\017\000\000\000\000\000\000\000\000\000\000\000\ \017\000\017\000\017\000\017\000\017\000\017\000\017\000\017\000\ \000\000\017\000\017\000\017\000\017\000\017\000\017\000\017\000\ \017\000\020\000\017\000\020\000\000\000\020\000\000\000\000\000\ \000\000\000\000\000\000\020\000\020\000\020\000\000\000\000\000\ \054\000\020\000\020\000\000\000\020\000\020\000\020\000\020\000\ \020\000\020\000\020\000\020\000\021\000\020\000\021\000\000\000\ \021\000\054\000\000\000\000\000\000\000\000\000\021\000\021\000\ \021\000\000\000\054\000\053\000\021\000\021\000\000\000\021\000\ \021\000\021\000\021\000\021\000\021\000\021\000\021\000\024\000\ \021\000\024\000\000\000\024\000\053\000\000\000\000\000\000\000\ \000\000\024\000\024\000\024\000\000\000\053\000\055\000\024\000\ \024\000\000\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\025\000\024\000\025\000\000\000\025\000\055\000\ \000\000\000\000\000\000\000\000\025\000\025\000\025\000\000\000\ \055\000\000\000\025\000\025\000\000\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\022\000\025\000\022\000\ \000\000\022\000\000\000\000\000\021\000\000\000\022\000\022\000\ \022\000\022\000\025\000\026\000\027\000\022\000\022\000\000\000\ \022\000\022\000\000\000\000\000\022\000\022\000\023\000\000\000\ \023\000\022\000\023\000\000\000\000\000\000\000\000\000\000\000\ \023\000\023\000\023\000\000\000\000\000\000\000\023\000\023\000\ \000\000\023\000\023\000\000\000\000\000\023\000\023\000\012\000\ \000\000\012\000\023\000\012\000\000\000\000\000\000\000\000\000\ \000\000\012\000\012\000\012\000\000\000\000\000\000\000\012\000\ \012\000\000\000\012\000\012\000\013\000\000\000\013\000\000\000\ \013\000\000\000\018\000\012\000\018\000\000\000\018\000\013\000\ \000\000\000\000\000\000\000\000\013\000\013\000\000\000\013\000\ \013\000\000\000\018\000\018\000\000\000\018\000\018\000\019\000\ \013\000\019\000\000\000\019\000\000\000\021\000\018\000\022\000\ \000\000\023\000\024\000\025\000\026\000\027\000\000\000\019\000\ \019\000\000\000\019\000\019\000\000\000\000\000\000\000\020\000\ \021\000\000\000\022\000\019\000\023\000\024\000\025\000\026\000\ \027\000\028\000\029\000\030\000\031\000\032\000\033\000\034\000\ \035\000\000\000\000\000\000\000\036\000\037\000\038\000\039\000\ \040\000\041\000\021\000\042\000\022\000\000\000\023\000\024\000\ \025\000\026\000\027\000\028\000\029\000\030\000\031\000\032\000\ \033\000\034\000\035\000\000\000\000\000\000\000\036\000\037\000\ \038\000\039\000\040\000\041\000\021\000\000\000\022\000\086\000\ \023\000\024\000\025\000\026\000\027\000\028\000\029\000\030\000\ \031\000\032\000\033\000\034\000\035\000\000\000\000\000\000\000\ \036\000\037\000\038\000\039\000\040\000\041\000\021\000\000\000\ \022\000\000\000\023\000\024\000\025\000\026\000\027\000\028\000\ \029\000\030\000\031\000\032\000\033\000\034\000\035\000\000\000\ \000\000\000\000\036\000\037\000\038\000\039\000\040\000\041\000\ \021\000\000\000\022\000\000\000\023\000\024\000\025\000\026\000\ \027\000\028\000\029\000\030\000\031\000\032\000\033\000\000\000\ \000\000\000\000\000\000\000\000\036\000\037\000\038\000\039\000\ \040\000\041\000\021\000\000\000\022\000\000\000\023\000\024\000\ \025\000\026\000\027\000\028\000\000\000\030\000\031\000\032\000\ \033\000\000\000\000\000\000\000\000\000\000\000\036\000\037\000\ \038\000\039\000\040\000\041\000\021\000\000\000\022\000\000\000\ \023\000\024\000\025\000\026\000\027\000\028\000\000\000\000\000\ \031\000\032\000\033\000\000\000\000\000\000\000\000\000\000\000\ \036\000\037\000\038\000\039\000\040\000\041\000\021\000\000\000\ \022\000\000\000\023\000\024\000\025\000\026\000\027\000\000\000\ \000\000\000\000\031\000\032\000\033\000\000\000\000\000\000\000\ \000\000\000\000\036\000\037\000\038\000\039\000\040\000\041\000\ \021\000\000\000\022\000\000\000\023\000\024\000\025\000\026\000\ \027\000\000\000\000\000\000\000\031\000\032\000\033\000\000\000\ \000\000\000\000\000\000\000\000\036\000\037\000\000\000\000\000\ \040\000\041\000\021\000\000\000\022\000\000\000\023\000\024\000\ \025\000\026\000\027\000\000\000\000\000\000\000\031\000\032\000\ \033\000" let yycheck = "\001\000\ \003\001\003\000\004\000\005\000\019\001\002\001\020\001\004\001\ \020\001\021\001\001\000\005\001\030\001\028\001\030\001\029\001\ \024\001\020\001\019\001\003\001\022\000\023\000\024\000\025\000\ \026\000\027\000\028\000\029\000\030\000\031\000\032\000\033\000\ \034\000\035\000\036\000\037\000\038\000\039\000\040\000\041\000\ \005\001\002\001\020\001\004\001\030\001\047\000\007\001\001\001\ \005\001\003\001\005\001\005\001\002\001\005\001\004\001\020\001\ \021\001\007\001\012\001\013\001\003\001\005\001\003\001\017\001\ \018\001\003\001\020\001\021\001\003\001\030\001\031\001\085\000\ \033\001\034\001\035\001\029\001\020\001\021\001\083\000\081\000\ \030\001\085\000\084\000\033\001\034\001\035\001\001\001\002\001\ \003\001\004\001\005\001\006\001\007\001\008\001\009\001\010\001\ \011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ \255\255\020\001\021\001\022\001\023\001\024\001\025\001\026\001\ \027\001\255\255\029\001\001\001\002\001\003\001\004\001\005\001\ \006\001\007\001\008\001\009\001\010\001\011\001\012\001\013\001\ \014\001\015\001\016\001\017\001\018\001\255\255\020\001\021\001\ \022\001\023\001\024\001\025\001\026\001\027\001\001\001\029\001\ \003\001\255\255\005\001\006\001\007\001\008\001\009\001\010\001\ \011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ \255\255\020\001\021\001\022\001\023\001\024\001\025\001\026\001\ \027\001\001\001\029\001\003\001\255\255\005\001\006\001\007\001\ \008\001\009\001\010\001\011\001\012\001\013\001\014\001\015\001\ \016\001\017\001\018\001\255\255\020\001\021\001\022\001\023\001\ \024\001\025\001\026\001\027\001\001\001\029\001\003\001\255\255\ \005\001\006\001\007\001\008\001\009\001\010\001\011\001\012\001\ \013\001\014\001\015\001\016\001\017\001\018\001\255\255\020\001\ \021\001\022\001\023\001\024\001\025\001\026\001\027\001\001\001\ \029\001\003\001\255\255\005\001\006\001\007\001\008\001\009\001\ \010\001\011\001\012\001\013\001\014\001\015\001\016\001\017\001\ \018\001\255\255\020\001\021\001\022\001\023\001\024\001\025\001\ \026\001\027\001\001\001\029\001\003\001\255\255\005\001\006\001\ \007\001\255\255\255\255\255\255\011\001\012\001\013\001\014\001\ \015\001\016\001\017\001\018\001\255\255\020\001\021\001\022\001\ \023\001\024\001\025\001\026\001\027\001\001\001\029\001\003\001\ \255\255\005\001\006\001\007\001\255\255\255\255\255\255\011\001\ \012\001\013\001\014\001\015\001\016\001\017\001\018\001\255\255\ \020\001\021\001\022\001\023\001\024\001\025\001\026\001\027\001\ \001\001\029\001\003\001\255\255\005\001\255\255\255\255\255\255\ \255\255\255\255\011\001\012\001\013\001\014\001\015\001\016\001\ \017\001\018\001\255\255\020\001\021\001\022\001\023\001\024\001\ \025\001\026\001\027\001\001\001\029\001\003\001\255\255\005\001\ \255\255\255\255\255\255\255\255\255\255\011\001\012\001\013\001\ \014\001\015\001\016\001\017\001\018\001\255\255\020\001\021\001\ \022\001\023\001\024\001\025\001\026\001\027\001\001\001\029\001\ \003\001\255\255\005\001\255\255\255\255\255\255\255\255\255\255\ \011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ \255\255\020\001\021\001\022\001\023\001\024\001\025\001\026\001\ \027\001\001\001\029\001\003\001\255\255\005\001\255\255\255\255\ \255\255\255\255\255\255\011\001\012\001\013\001\255\255\255\255\ \003\001\017\001\018\001\255\255\020\001\021\001\022\001\023\001\ \024\001\025\001\026\001\027\001\001\001\029\001\003\001\255\255\ \005\001\020\001\255\255\255\255\255\255\255\255\011\001\012\001\ \013\001\255\255\029\001\003\001\017\001\018\001\255\255\020\001\ \021\001\022\001\023\001\024\001\025\001\026\001\027\001\001\001\ \029\001\003\001\255\255\005\001\020\001\255\255\255\255\255\255\ \255\255\011\001\012\001\013\001\255\255\029\001\003\001\017\001\ \018\001\255\255\020\001\021\001\022\001\023\001\024\001\025\001\ \026\001\027\001\001\001\029\001\003\001\255\255\005\001\020\001\ \255\255\255\255\255\255\255\255\011\001\012\001\013\001\255\255\ \029\001\255\255\017\001\018\001\255\255\020\001\021\001\022\001\ \023\001\024\001\025\001\026\001\027\001\001\001\029\001\003\001\ \255\255\005\001\255\255\255\255\002\001\255\255\004\001\011\001\ \012\001\013\001\008\001\009\001\010\001\017\001\018\001\255\255\ \020\001\021\001\255\255\255\255\024\001\025\001\001\001\255\255\ \003\001\029\001\005\001\255\255\255\255\255\255\255\255\255\255\ \011\001\012\001\013\001\255\255\255\255\255\255\017\001\018\001\ \255\255\020\001\021\001\255\255\255\255\024\001\025\001\001\001\ \255\255\003\001\029\001\005\001\255\255\255\255\255\255\255\255\ \255\255\011\001\012\001\013\001\255\255\255\255\255\255\017\001\ \018\001\255\255\020\001\021\001\001\001\255\255\003\001\255\255\ \005\001\255\255\001\001\029\001\003\001\255\255\005\001\012\001\ \255\255\255\255\255\255\255\255\017\001\018\001\255\255\020\001\ \021\001\255\255\017\001\018\001\255\255\020\001\021\001\001\001\ \029\001\003\001\255\255\005\001\255\255\002\001\029\001\004\001\ \255\255\006\001\007\001\008\001\009\001\010\001\255\255\017\001\ \018\001\255\255\020\001\021\001\255\255\255\255\255\255\001\001\ \002\001\255\255\004\001\029\001\006\001\007\001\008\001\009\001\ \010\001\011\001\012\001\013\001\014\001\015\001\016\001\017\001\ \018\001\255\255\255\255\255\255\022\001\023\001\024\001\025\001\ \026\001\027\001\002\001\003\001\004\001\255\255\006\001\007\001\ \008\001\009\001\010\001\011\001\012\001\013\001\014\001\015\001\ \016\001\017\001\018\001\255\255\255\255\255\255\022\001\023\001\ \024\001\025\001\026\001\027\001\002\001\255\255\004\001\005\001\ \006\001\007\001\008\001\009\001\010\001\011\001\012\001\013\001\ \014\001\015\001\016\001\017\001\018\001\255\255\255\255\255\255\ \022\001\023\001\024\001\025\001\026\001\027\001\002\001\255\255\ \004\001\255\255\006\001\007\001\008\001\009\001\010\001\011\001\ \012\001\013\001\014\001\015\001\016\001\017\001\018\001\255\255\ \255\255\255\255\022\001\023\001\024\001\025\001\026\001\027\001\ \002\001\255\255\004\001\255\255\006\001\007\001\008\001\009\001\ \010\001\011\001\012\001\013\001\014\001\015\001\016\001\255\255\ \255\255\255\255\255\255\255\255\022\001\023\001\024\001\025\001\ \026\001\027\001\002\001\255\255\004\001\255\255\006\001\007\001\ \008\001\009\001\010\001\011\001\255\255\013\001\014\001\015\001\ \016\001\255\255\255\255\255\255\255\255\255\255\022\001\023\001\ \024\001\025\001\026\001\027\001\002\001\255\255\004\001\255\255\ \006\001\007\001\008\001\009\001\010\001\011\001\255\255\255\255\ \014\001\015\001\016\001\255\255\255\255\255\255\255\255\255\255\ \022\001\023\001\024\001\025\001\026\001\027\001\002\001\255\255\ \004\001\255\255\006\001\007\001\008\001\009\001\010\001\255\255\ \255\255\255\255\014\001\015\001\016\001\255\255\255\255\255\255\ \255\255\255\255\022\001\023\001\024\001\025\001\026\001\027\001\ \002\001\255\255\004\001\255\255\006\001\007\001\008\001\009\001\ \010\001\255\255\255\255\255\255\014\001\015\001\016\001\255\255\ \255\255\255\255\255\255\255\255\022\001\023\001\255\255\255\255\ \026\001\027\001\002\001\255\255\004\001\255\255\006\001\007\001\ \008\001\009\001\010\001\255\255\255\255\255\255\014\001\015\001\ \016\001" let yynames_const = "\ TokEof\000\ " let yynames_block = "\ TokLeftParen\000\ TokRightParen\000\ TokLeftBrack\000\ TokRightBrack\000\ TokPlus\000\ TokMinus\000\ TokStar\000\ TokSlash\000\ TokMod\000\ TokHat\000\ TokPipe\000\ TokAmp\000\ TokLsl\000\ TokLsr\000\ TokAsr\000\ TokAnd\000\ TokOr\000\ TokDot\000\ TokComma\000\ TokSemi\000\ TokLe\000\ TokLt\000\ TokEq\000\ TokNeq\000\ TokGt\000\ TokGe\000\ TokColonColon\000\ TokArrow\000\ TokId\000\ TokKey\000\ TokCatch\000\ TokInt\000\ TokFloat\000\ TokExp\000\ " let yyact = [| (fun _ -> failwith "parser") ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 173 "omake_exp_parse.mly" ( let e, _ = _1 in e ) # 490 "omake_exp_parse.ml" : Omake_ast.exp)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : int * Lm_location.t) in Obj.repr( # 178 "omake_exp_parse.mly" ( let i, loc = _1 in IntExp (i, loc), loc ) # 499 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : float * Lm_location.t) in Obj.repr( # 182 "omake_exp_parse.mly" ( let x, loc = _1 in FloatExp (x, loc), loc ) # 508 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp) in Obj.repr( # 186 "omake_exp_parse.mly" ( let e = _1 in e, loc_of_exp e ) # 517 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'id) in Obj.repr( # 190 "omake_exp_parse.mly" ( make_id_exp _1 ) # 524 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 192 "omake_exp_parse.mly" ( make_unary_exp neg_fun_sym _2 ) # 532 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 194 "omake_exp_parse.mly" ( make_binary_exp add_fun_sym _1 _3 ) # 541 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 196 "omake_exp_parse.mly" ( make_binary_exp sub_fun_sym _1 _3 ) # 550 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 198 "omake_exp_parse.mly" ( make_binary_exp mul_fun_sym _1 _3 ) # 559 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 200 "omake_exp_parse.mly" ( make_binary_exp div_fun_sym _1 _3 ) # 568 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 202 "omake_exp_parse.mly" ( make_binary_exp mod_fun_sym _1 _3 ) # 577 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 204 "omake_exp_parse.mly" ( make_binary_exp lxor_fun_sym _1 _3 ) # 586 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 206 "omake_exp_parse.mly" ( make_binary_exp lor_fun_sym _1 _3 ) # 595 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 208 "omake_exp_parse.mly" ( make_binary_exp land_fun_sym _1 _3 ) # 604 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 210 "omake_exp_parse.mly" ( make_binary_exp lsl_fun_sym _1 _3 ) # 613 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 212 "omake_exp_parse.mly" ( make_binary_exp lsr_fun_sym _1 _3 ) # 622 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 214 "omake_exp_parse.mly" ( make_binary_exp asr_fun_sym _1 _3 ) # 631 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 216 "omake_exp_parse.mly" ( make_binary_exp and_fun_sym _1 _3 ) # 640 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 218 "omake_exp_parse.mly" ( make_binary_exp or_fun_sym _1 _3 ) # 649 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 220 "omake_exp_parse.mly" ( make_binary_exp le_fun_sym _1 _3 ) # 658 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 222 "omake_exp_parse.mly" ( make_binary_exp lt_fun_sym _1 _3 ) # 667 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 224 "omake_exp_parse.mly" ( make_binary_exp equal_fun_sym _1 _3 ) # 676 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 226 "omake_exp_parse.mly" ( make_binary_exp nequal_fun_sym _1 _3 ) # 685 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 228 "omake_exp_parse.mly" ( make_binary_exp gt_fun_sym _1 _3 ) # 694 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 230 "omake_exp_parse.mly" ( make_binary_exp ge_fun_sym _1 _3 ) # 703 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 2 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_args) in let _4 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 232 "omake_exp_parse.mly" ( make_apply_exp _1 _3 ) # 713 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : Omake_ast.exp * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 2 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : Omake_ast.exp * Lm_location.t) in let _4 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 234 "omake_exp_parse.mly" ( make_binary_exp nth_fun_sym _3 _1 ) # 723 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Omake_ast.exp * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 236 "omake_exp_parse.mly" ( _2 ) # 732 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : 'opt_exp_list) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 238 "omake_exp_parse.mly" ( let loc = union_loc _1 _3 in ArrayExp (_2, loc), loc ) # 743 "omake_exp_parse.ml" : Omake_ast.exp * Lm_location.t)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Lm_symbol.t * Lm_location.t) in Obj.repr( # 245 "omake_exp_parse.mly" ( let id, loc = _1 in SimpleId id, loc ) # 752 "omake_exp_parse.ml" : 'id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Lm_symbol.t * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Lm_symbol.t * Lm_location.t) in Obj.repr( # 249 "omake_exp_parse.mly" ( let v1, loc1 = _1 in let v2, loc2 = _3 in let loc = union_loc loc1 loc2 in SuperId (v1, v2), loc ) # 765 "omake_exp_parse.ml" : 'id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Lm_symbol.t * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'rev_path_id) in Obj.repr( # 255 "omake_exp_parse.mly" ( let v1, loc1 = _1 in let vars, loc2 = _3 in let loc = union_loc loc1 loc2 in MethodId (v1 :: vars), loc ) # 778 "omake_exp_parse.ml" : 'id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Lm_symbol.t * Lm_location.t) in Obj.repr( # 264 "omake_exp_parse.mly" ( let v, loc = _1 in [v], loc ) # 787 "omake_exp_parse.ml" : 'rev_path_id)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'rev_path_id) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Lm_symbol.t * Lm_location.t) in Obj.repr( # 268 "omake_exp_parse.mly" ( let path, loc1 = _1 in let v, loc2 = _3 in let loc = union_loc loc1 loc2 in v :: path, loc ) # 800 "omake_exp_parse.ml" : 'rev_path_id)) ; (fun __caml_parser_env -> Obj.repr( # 280 "omake_exp_parse.mly" ( [] ) # 806 "omake_exp_parse.ml" : 'opt_exp_list)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_exp_list) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'opt_semi_or_comma) in Obj.repr( # 282 "omake_exp_parse.mly" ( List.rev _1 ) # 814 "omake_exp_parse.ml" : 'opt_exp_list)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 287 "omake_exp_parse.mly" ( let e, _ = _1 in [e] ) # 821 "omake_exp_parse.ml" : 'rev_exp_list)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'rev_exp_list) in let _2 = (Parsing.peek_val __caml_parser_env 1 : 'semi_or_comma) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 289 "omake_exp_parse.mly" ( let e, _ = _3 in e :: _1 ) # 832 "omake_exp_parse.ml" : 'rev_exp_list)) ; (fun __caml_parser_env -> Obj.repr( # 296 "omake_exp_parse.mly" ( () ) # 838 "omake_exp_parse.ml" : 'opt_semi_or_comma)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'semi_or_comma) in Obj.repr( # 298 "omake_exp_parse.mly" ( () ) # 845 "omake_exp_parse.ml" : 'opt_semi_or_comma)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 303 "omake_exp_parse.mly" ( _1 ) # 852 "omake_exp_parse.ml" : 'semi_or_comma)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 305 "omake_exp_parse.mly" ( _1 ) # 859 "omake_exp_parse.ml" : 'semi_or_comma)) ; (fun __caml_parser_env -> Obj.repr( # 313 "omake_exp_parse.mly" ( [] ) # 865 "omake_exp_parse.ml" : 'opt_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'args) in Obj.repr( # 315 "omake_exp_parse.mly" ( _1 ) # 872 "omake_exp_parse.ml" : 'opt_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_args) in Obj.repr( # 319 "omake_exp_parse.mly" ( List.rev _1 ) # 879 "omake_exp_parse.ml" : 'args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_arrow_args) in Obj.repr( # 321 "omake_exp_parse.mly" ( List.rev _1 ) # 886 "omake_exp_parse.ml" : 'args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'rev_arrow_args) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'rev_args) in Obj.repr( # 323 "omake_exp_parse.mly" ( List.rev_append _1 (List.rev _3) ) # 895 "omake_exp_parse.ml" : 'args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arrow_arg) in Obj.repr( # 328 "omake_exp_parse.mly" ( [_1] ) # 902 "omake_exp_parse.ml" : 'rev_arrow_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'rev_arrow_args) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arrow_arg) in Obj.repr( # 330 "omake_exp_parse.mly" ( _3 :: _1 ) # 911 "omake_exp_parse.ml" : 'rev_arrow_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'rev_args) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 335 "omake_exp_parse.mly" ( let e, _ = _3 in ArrowArg (get_fun_params (List.rev _1), e) ) # 922 "omake_exp_parse.ml" : 'arrow_arg)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arg) in Obj.repr( # 342 "omake_exp_parse.mly" ( [_1] ) # 929 "omake_exp_parse.ml" : 'rev_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'rev_args) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arg) in Obj.repr( # 344 "omake_exp_parse.mly" ( _3 :: _1 ) # 938 "omake_exp_parse.ml" : 'rev_args)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 348 "omake_exp_parse.mly" ( let e, _ = _1 in ExpArg e ) # 947 "omake_exp_parse.ml" : 'arg)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Lm_symbol.t * Lm_location.t) in Obj.repr( # 352 "omake_exp_parse.mly" ( let key, loc = _1 in KeyArg (key, NullExp loc) ) # 956 "omake_exp_parse.ml" : 'arg)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Lm_symbol.t * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : Omake_ast.exp * Lm_location.t) in Obj.repr( # 356 "omake_exp_parse.mly" ( let key, _ = _1 in let e, _ = _3 in KeyArg (key, e) ) # 968 "omake_exp_parse.ml" : 'arg)) (* Entry ast_exp *) ; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) |] let yytables = { Parsing.actions=yyact; Parsing.transl_const=yytransl_const; Parsing.transl_block=yytransl_block; Parsing.lhs=yylhs; Parsing.len=yylen; Parsing.defred=yydefred; Parsing.dgoto=yydgoto; Parsing.sindex=yysindex; Parsing.rindex=yyrindex; Parsing.gindex=yygindex; Parsing.tablesize=yytablesize; Parsing.table=yytable; Parsing.check=yycheck; Parsing.error_function=parse_error; Parsing.names_const=yynames_const; Parsing.names_block=yynames_block } let ast_exp (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = (Parsing.yyparse yytables 1 lexfun lexbuf : Omake_ast.exp) omake-0.10.3/src/env/omake_exn_print.ml0000644000175000017500000001011413177364665016425 0ustar gerdgerdopen Omake_env open Omake_symbol open Omake_value_type open Omake_value_print module Pos= Omake_pos.Make (struct let name = "Omake_exn_print" end);; (* * Other exception. *) let pp_print_other_exn buf exn = match exn with | Unix.Unix_error (errno, f, arg) -> Format.fprintf buf "@[%s(%s): %s@]" (**) f arg (Unix.error_message errno) | Sys_error s -> Format.fprintf buf "@[Sys_error: %s@]" s | Sys.Break -> Format.fprintf buf "@[Break@]" | Failure s -> Format.fprintf buf "Failure: %s" s | Invalid_argument s -> Format.fprintf buf "Invalid argument: %s" s | exn -> Format.fprintf buf "@[%s@]" (**) (Printexc.to_string exn) let pp_print_obj_err buf obj = if venv_defined_field_internal obj message_sym then match venv_find_field_internal_exn obj message_sym with ValString s | ValData s -> begin match Lm_string_util.split "\n" s with [] -> () | s :: sl -> Format.pp_print_string buf s; List.iter (fun s -> Format.pp_force_newline buf (); Format.pp_print_string buf s) sl end | v -> pp_print_value buf v else pp_print_value buf (ValObject obj) (* * Exception printer. *) let pp_print_return_id buf (loc, s) = Format.fprintf buf "%s (%a)" s Lm_location.pp_print_location loc let pp_print_exn_with_backtrace ~backtrace buf exn = match exn with OmakeException (pos, exn) -> Format.fprintf buf "@[*** omake error:@ %a@ %a@]" (**) Pos.pp_print_pos pos pp_print_exn exn | OmakeFatalErr (pos, exn) -> Format.fprintf buf "@[*** omake fatal error:@ %a@ %a@]" (**) Pos.pp_print_pos pos pp_print_exn exn | UncaughtException (pos, exn) -> Format.fprintf buf "@[*** omake error:@ %a@ %a@]" (**) Pos.pp_print_pos pos pp_print_other_exn exn | RaiseException (pos, obj) -> Format.fprintf buf "@[*** omake error:@ %a@ @[Uncaught Exception:@ %a@]@]" (**) Pos.pp_print_pos pos pp_print_obj_err obj | OmakeFatal s -> Format.fprintf buf "@[*** omake fatal error:@ %s@]" s | ExitParentException (pos, code) | ExitException (pos, code) -> Format.fprintf buf "@[*** omake %s:@ %a@ early exit(%i) requested by an omake file@]" (**) (if code = 0 then "warning" else "error") Pos.pp_print_pos pos code | Return (loc, _, id) -> Format.fprintf buf "@[*** omake error:@ %a@ uncaught return from %a@]" (**) Lm_location.pp_print_location loc pp_print_return_id id | (Unix.Unix_error _ | Sys_error _ ) as exn -> Format.fprintf buf "@[*** omake error:@ %a@]" pp_print_other_exn exn | exn -> Format.fprintf buf "@[*** omake error:@ %a@]" pp_print_other_exn exn; if backtrace <> "" then Format.fprintf buf "@[ - backtrace: %s@]" backtrace let pp_print_exn buf exn = pp_print_exn_with_backtrace ~backtrace:"" buf exn (* * If one of these exceptions occurs during process creation, * treat it as a command failure. *) let is_shell_exn exn = match exn with | OmakeException _ | OmakeFatalErr _ | OmakeFatal _ | UncaughtException _ | RaiseException _ | Unix.Unix_error _ | Sys_error _ | Return _ -> true | _ -> false (* * Exception handler. *) let catch f x = Printexc.record_backtrace true; try f x with | OmakeException _ | OmakeFatalErr _ | OmakeFatal _ | UncaughtException _ | RaiseException _ | Unix.Unix_error _ | Sys_error _ | Return _ | Out_of_memory as exn -> Format.eprintf "%a@." pp_print_exn exn; exit Omake_state.exn_error_code | ExitParentException (_, code) | ExitException (_, code) as exn -> Format.eprintf "%a@." pp_print_exn exn; exit code | exn -> let backtrace = Printexc.get_backtrace() in Format.eprintf "%a@." (pp_print_exn_with_backtrace ~backtrace) exn; exit Omake_state.exn_error_code omake-0.10.3/src/env/omake_command_digest.ml0000644000175000017500000007043413177364665017407 0ustar gerdgerd(* * Compute the digest of a value. This works the naive way: * 1. Convert the value to a string * 2. Compute its MD5 digest * This can be fairly expensive if the value is big. The * current implementation is designed so that we can at least * compress the string a bit. *) (* %%MAGICBEGIN%% *) type code = CodeApplyExp | CodeApplyString | CodeFunString | CodeArgv | CodeArrayOfString | CodeArrayString | CodeArrow | CodeBegin | CodeObjectString | CodeBodyString | CodeCase | CodeCaseExp | CodeCases | CodeCasesExp | CodeCasesString | CodeCaseString | CodeCommaExp | CodeCommand | CodeCommands | CodeNoneString | CodeIntString | CodeFloatString | CodeWhiteString | CodeConstString | CodeVarString | CodeEnd | CodeExpString | CodeIfExp | CodeOpenExp | CodeIncludeExp | CodeLetFunExp | CodeLetObjectExp | CodeLetThisExp | CodeLetVarExp | CodeMethodApplyExp | CodeMethodApplyString | CodeQuoteString | CodeQuoteStringString | CodeExportNone | CodeExportAll | CodeExportList | CodeExportRules | CodeExportPhonies | CodeExportVar | CodeReturnBodyExp | CodeStringExp | CodeReturnExp | CodeReturnObjectExp | CodeReturnSaveExp (* | CodeVarScopePrivate *) (* report Mantis location incorrect {|File "/Users/hongbozhang/omake-fork/src/env/omake_command_digest.ml", line 12, characters 5-2211: Warning 37: unused constructor CodeVarScopePrivate. |}*) (* | CodeVarScopeThis *) (* | CodeVarScopeVirtual *) (* | CodeVarScopeGlobal *) | CodeVarPrivate | CodeVarThis | CodeVarVirtual | CodeVarGlobal | CodeSectionExp | CodeSequenceExp | CodeSequenceString | CodeShellExp | CodeStaticExp | CodeSpace | CodeSuperApplyExp | CodeSuperApplyString | CodeThisString | CodeValArray | CodeValStringExp | CodeValBody | CodeValData | CodeValDir | CodeValFloat | CodeValFun | CodeValFunCurry | CodeValInt | CodeValMap | CodeValNode | CodeValNone | CodeValObject | CodeValPrim | CodeValPrimCurry | CodeValQuote | CodeValQuoteString | CodeValSequence | CodeValWhite | CodeValString | CodeValVar | CodeValMaybeApply | CodeVarDefApply | CodeVarDefNormal | CodeLetKeyExp | CodeKeyApplyString | CodeKeyExp | CodeValStaticApply | CodeArg | CodeArgString | CodeArgData | CodePipeAnd | CodePipeOr | CodePipeSequence | CodePipeCommand | CodePipeApply | CodePipeCond | CodePipeCompose | CodePipeGroup | CodePipeBackground | CodeCommandEnvItem | CodeCommandEnv (* | CodeQuietFlag *) (* | CodeAllowFailureFlag *) (* | CodeAllowOutputFlag *) (* | CodeCommandFlags *) | CodeCmdArg | CodeCmdNode | CodePipe | CodeRedirectNode | CodeRedirectArg | CodeRedirectNone (* | CodeKeywordSpec *) (* | CodeKeywordSpecList *) | CodeNone | CodeSome | CodeLazyString | CodeLetVarString (* %%MAGICEND%% *) (* %%MAGICBEGIN%% *) module Hash = Lm_hash_code.HashDigest let add_code buf (code : code) = Hash.add_bits buf (Obj.magic code) (* %%MAGICEND%% *) (* * Variable squashing. *) let squash_var buf v = Hash.add_string buf (Lm_symbol.string_of_symbol v) let rec squash_vars buf vars = match vars with [v] -> squash_var buf v | v :: vars -> squash_var buf v; add_code buf CodeSpace; squash_vars buf vars | [] -> () (* let squash_var_set buf vars = *) (* Lm_symbol.SymbolSet.iter (fun v -> *) (* add_code buf CodeSpace; *) (* squash_var buf v) vars *) let squash_var_info buf v = match v with Omake_ir.VarPrivate (_, v) -> add_code buf CodeVarPrivate; add_code buf CodeSpace; squash_var buf v | VarThis (_, v) -> add_code buf CodeVarThis; add_code buf CodeSpace; squash_var buf v | VarVirtual (_, v) -> add_code buf CodeVarVirtual; add_code buf CodeSpace; squash_var buf v | VarGlobal (_, v) -> add_code buf CodeVarGlobal; add_code buf CodeSpace; squash_var buf v let rec squash_var_info_list buf vars = match vars with [v] -> squash_var_info buf v | v :: vars -> squash_var_info buf v; add_code buf CodeSpace; squash_var_info_list buf vars | [] -> () let squash_params = squash_var_info_list (* let squash_keyword_spec buf (v, required) = *) (* add_code buf CodeKeywordSpec; *) (* squash_var buf v; *) (* Hash.add_bool buf required *) (* let squash_keyword_spec_list buf keywords = *) (* add_code buf CodeKeywordSpecList; *) (* List.iter (squash_keyword_spec buf) keywords *) (* * File. *) let squash_node buf node = Hash.add_string buf (Omake_node.Node.absname node) (* * String representations. *) (* let squash_var_scope buf scope = *) (* let code = *) (* match scope with *) (* Omake_ir.VarScopePrivate -> CodeVarScopePrivate *) (* | VarScopeThis -> CodeVarScopeThis *) (* | VarScopeVirtual -> CodeVarScopeVirtual *) (* | VarScopeGlobal -> CodeVarScopeGlobal *) (* in *) (* add_code buf code *) let squash_def_kind buf kind = let s = match kind with Omake_ir.VarDefNormal -> CodeVarDefNormal | VarDefAppend -> CodeVarDefApply in add_code buf s (* * Export info. *) let squash_export_info buf info = match info with Omake_ir.ExportNone -> add_code buf CodeExportNone | Omake_ir.ExportAll -> add_code buf CodeExportAll | Omake_ir.ExportList items -> add_code buf CodeExportList; List.iter (fun item -> match item with Omake_ir.ExportRules -> add_code buf CodeExportRules | Omake_ir.ExportPhonies -> add_code buf CodeExportPhonies | Omake_ir.ExportVar v -> add_code buf CodeExportVar; squash_var_info buf v) items (* * Just squash the string part of the return is. *) let squash_return_id buf (_, s) = Hash.add_string buf s (* * Squash string expressions. *) let rec squash_string_exp pos buf e = add_code buf CodeBegin; begin match e with Omake_ir.NoneString _ -> add_code buf CodeNoneString | IntString (_, i) -> add_code buf CodeIntString; Hash.add_int buf i | FloatString (_, x) -> add_code buf CodeFloatString; Hash.add_float buf x | WhiteString (_, s) -> add_code buf CodeWhiteString; Hash.add_string buf s | ConstString (_, s) -> add_code buf CodeConstString; Hash.add_string buf s | VarString (_, v) -> add_code buf CodeVarString; squash_var_info buf v | KeyApplyString (_, s) -> add_code buf CodeKeyApplyString; Hash.add_string buf s | FunString (_, opt_params, params, s, export) -> add_code buf CodeFunString; squash_params buf params; add_code buf CodeArrow; squash_keyword_param_list pos buf opt_params; add_code buf CodeArrow; squash_exp_list pos buf s; add_code buf CodeSpace; squash_export_info buf export | ApplyString (_, v, args, kargs) -> add_code buf CodeApplyString; squash_var_info buf v; add_code buf CodeSpace; squash_string_exp_list pos buf args; squash_keyword_exp_list pos buf kargs | SuperApplyString (_, v1, v2, args, kargs) -> add_code buf CodeSuperApplyString; squash_var buf v1; add_code buf CodeSpace; squash_var buf v2; add_code buf CodeSpace; squash_string_exp_list pos buf args; squash_keyword_exp_list pos buf kargs | MethodApplyString (_, v, vars, args, kargs) -> add_code buf CodeMethodApplyString; squash_var_info buf v; add_code buf CodeSpace; squash_vars buf vars; add_code buf CodeSpace; squash_string_exp_list pos buf args; squash_keyword_exp_list pos buf kargs | SequenceString (_, sl) -> add_code buf CodeSequenceString; squash_string_exp_list pos buf sl | ArrayString (_, sl) -> add_code buf CodeArrayString; squash_string_exp_list pos buf sl | ArrayOfString (_, s) -> add_code buf CodeArrayOfString; squash_string_exp pos buf s | QuoteString (_, sl) -> add_code buf CodeQuoteString; squash_string_exp_list pos buf sl | QuoteStringString (_, c, sl) -> add_code buf CodeQuoteStringString; Hash.add_char buf c; squash_string_exp_list pos buf sl | ObjectString (_, el, export) -> add_code buf CodeObjectString; squash_exp_list pos buf el; add_code buf CodeSpace; squash_export_info buf export | BodyString (_, el, export) -> add_code buf CodeBodyString; squash_exp_list pos buf el; add_code buf CodeSpace; squash_export_info buf export | ExpString (_, el, export) -> add_code buf CodeExpString; squash_exp_list pos buf el; add_code buf CodeSpace; squash_export_info buf export | CasesString (_, cases) -> add_code buf CodeCasesString; squash_cases_exp pos buf cases | ThisString _ -> add_code buf CodeThisString | LazyString (_, s) -> add_code buf CodeLazyString; squash_string_exp pos buf s | LetVarString (_, v, s1, s2) -> add_code buf CodeLetVarString; squash_var_info buf v; add_code buf CodeSpace; squash_string_exp pos buf s1; add_code buf CodeSpace; squash_string_exp pos buf s2 end; add_code buf CodeEnd and squash_opt_string_exp pos buf = function Some s -> add_code buf CodeSome; squash_string_exp pos buf s | None -> add_code buf CodeNone and squash_string_exp_list pos buf sl = match sl with [s] -> squash_string_exp pos buf s | s :: sl -> squash_string_exp pos buf s; add_code buf CodeSpace; squash_string_exp_list pos buf sl | [] -> () and squash_keyword_exp_list pos buf kargs = match kargs with (v, arg) :: kargs -> add_code buf CodeSpace; squash_var buf v; add_code buf CodeSpace; squash_string_exp pos buf arg; squash_keyword_exp_list pos buf kargs | [] -> () and squash_keyword_param_list pos buf kargs = match kargs with (v, v_info, opt_arg) :: kargs -> add_code buf CodeSpace; squash_var buf v; add_code buf CodeSpace; squash_var_info buf v_info; add_code buf CodeSpace; squash_opt_string_exp pos buf opt_arg; squash_keyword_param_list pos buf kargs | [] -> () and squash_case_exp pos buf (v, s, el, export) = add_code buf CodeCaseString; squash_var buf v; add_code buf CodeSpace; squash_string_exp pos buf s; add_code buf CodeSpace; squash_exp_list pos buf el; add_code buf CodeSpace; squash_export_info buf export; add_code buf CodeEnd and squash_cases_exp pos buf cases = add_code buf CodeCasesString; List.iter (squash_case_exp pos buf) cases; add_code buf CodeEnd (* * Squash an expression. *) and squash_exp pos buf e = add_code buf CodeBegin; begin match e with Omake_ir.LetVarExp (_, v, vl, def, s) -> add_code buf CodeLetVarExp; squash_var_info buf v; add_code buf CodeSpace; squash_vars buf vl; add_code buf CodeSpace; squash_def_kind buf def; add_code buf CodeSpace; squash_string_exp pos buf s | KeyExp (_, v) -> add_code buf CodeKeyExp; Hash.add_string buf v | LetKeyExp (_, v, def, s) -> add_code buf CodeLetKeyExp; Hash.add_string buf v; add_code buf CodeSpace; squash_def_kind buf def; add_code buf CodeSpace; squash_string_exp pos buf s | LetFunExp (_, v, vl, curry, opt_params, params, s, export) -> add_code buf CodeLetFunExp; squash_var_info buf v; add_code buf CodeSpace; squash_vars buf vl; add_code buf CodeSpace; Hash.add_bool buf curry; squash_keyword_param_list pos buf opt_params; add_code buf CodeSpace; squash_params buf params; add_code buf CodeSpace; squash_exp_list pos buf s; add_code buf CodeSpace; squash_export_info buf export | LetObjectExp (_, v, vl, s, el, export) -> add_code buf CodeLetObjectExp; squash_var_info buf v; add_code buf CodeSpace; squash_vars buf vl; add_code buf CodeSpace; squash_string_exp pos buf s; add_code buf CodeSpace; squash_exp_list pos buf el; add_code buf CodeSpace; squash_export_info buf export | LetThisExp (_, s) -> add_code buf CodeLetThisExp; squash_string_exp pos buf s | ShellExp (_, s) -> add_code buf CodeShellExp; squash_string_exp pos buf s | IfExp (_, cases) -> add_code buf CodeIfExp; squash_if_cases pos buf cases | SequenceExp (_, el) -> add_code buf CodeSequenceExp; squash_exp_list pos buf el | SectionExp (_, s, el, export) -> add_code buf CodeSectionExp; squash_string_exp pos buf s; add_code buf CodeArrow; squash_exp_list pos buf el; add_code buf CodeSpace; squash_export_info buf export | OpenExp (_, nodes) -> add_code buf CodeOpenExp; List.iter (fun node -> add_code buf CodeCommaExp; squash_node buf node) nodes | IncludeExp (_, s, sl) -> add_code buf CodeIncludeExp; squash_string_exp pos buf s; add_code buf CodeCommaExp; squash_string_exp_list pos buf sl | ApplyExp (_, v, args, kargs) -> add_code buf CodeApplyExp; squash_var_info buf v; add_code buf CodeSpace; squash_string_exp_list pos buf args; squash_keyword_exp_list pos buf kargs | SuperApplyExp (_, v1, v2, args, kargs) -> add_code buf CodeSuperApplyExp; squash_var buf v1; add_code buf CodeSpace; squash_var buf v2; add_code buf CodeSpace; squash_string_exp_list pos buf args; squash_keyword_exp_list pos buf kargs | MethodApplyExp (_, v, vars, args, kargs) -> add_code buf CodeMethodApplyExp; squash_var_info buf v; add_code buf CodeSpace; squash_vars buf vars; add_code buf CodeSpace; squash_string_exp_list pos buf args; squash_keyword_exp_list pos buf kargs | ReturnBodyExp (_, el, id) -> add_code buf CodeReturnBodyExp; squash_exp_list pos buf el; squash_return_id buf id | StringExp (_, s) -> add_code buf CodeStringExp; squash_string_exp pos buf s | ReturnExp (_, s, id) -> add_code buf CodeReturnExp; squash_string_exp pos buf s; squash_return_id buf id | ReturnObjectExp (_, vars) -> add_code buf CodeReturnObjectExp; squash_vars buf vars | ReturnSaveExp _ -> add_code buf CodeReturnSaveExp | StaticExp (_, node, key, el) -> add_code buf CodeStaticExp; squash_node buf node; add_code buf CodeSpace; squash_var buf key; add_code buf CodeSpace; squash_exp_list pos buf el end; add_code buf CodeEnd and squash_exp_list pos buf el = match el with [e] -> squash_exp pos buf e | e :: el -> squash_exp pos buf e; add_code buf CodeSpace; squash_exp_list pos buf el | [] -> () and squash_if_case pos buf (s, el, export) = add_code buf CodeCaseExp; squash_string_exp pos buf s; add_code buf CodeSpace; squash_exp_list pos buf el; add_code buf CodeSpace; squash_export_info buf export; add_code buf CodeEnd and squash_if_cases pos buf cases = add_code buf CodeCasesExp; List.iter (squash_if_case pos buf) cases; add_code buf CodeEnd (* * Compute the digest of a value. *) let rec squash_value pos buf v = add_code buf CodeBegin; begin match v with |Omake_value_type.ValNone -> add_code buf CodeValNone; | ValInt i -> add_code buf CodeValInt; Hash.add_int buf i | ValFloat x -> add_code buf CodeValFloat; Hash.add_float buf x | ValSequence vl -> add_code buf CodeValSequence; squash_values pos buf vl | ValArray vl -> add_code buf CodeValArray; squash_values pos buf vl | ValWhite s -> add_code buf CodeValWhite; Hash.add_string buf s | ValString s -> add_code buf CodeValString; Hash.add_string buf s | ValData s -> add_code buf CodeValData; Hash.add_string buf s | ValQuote vl -> add_code buf CodeValQuote; squash_values pos buf vl | ValQuoteString (c, vl) -> add_code buf CodeValQuoteString; Hash.add_char buf c; squash_values pos buf vl | ValMaybeApply (_, v) -> add_code buf CodeValMaybeApply; squash_var_info buf v | ValFun (_, keywords, params, body, export) -> add_code buf CodeValFun; squash_keyword_param_values pos buf keywords; add_code buf CodeSpace; squash_params buf params; add_code buf CodeArrow; squash_exp_list pos buf body; add_code buf CodeSpace; squash_export_info buf export | ValFunCurry (_, args, keywords, params, body, export, kargs) -> add_code buf CodeValFunCurry; squash_param_values pos buf args; add_code buf CodeSpace; squash_keyword_param_values pos buf keywords; add_code buf CodeSpace; squash_params buf params; add_code buf CodeArrow; squash_exp_list pos buf body; add_code buf CodeSpace; squash_export_info buf export; squash_keyword_values pos buf kargs | ValPrim (_, _, _, f) -> add_code buf CodeValPrim; squash_var buf (Omake_env.squash_prim_fun f) | ValPrimCurry (_, _, f, args, kargs) -> add_code buf CodeValPrimCurry; squash_var buf (Omake_env.squash_prim_fun f); add_code buf CodeSpace; squash_values pos buf args; squash_keyword_values pos buf kargs | ValNode node -> add_code buf CodeValNode; Hash.add_string buf (Omake_node.Node.fullname node) | ValDir dir -> add_code buf CodeValDir; Hash.add_string buf (Omake_node.Dir.fullname dir) | ValStringExp (_, e) -> add_code buf CodeValStringExp; squash_string_exp pos buf e | ValBody (_, keywords, params, e, export) -> add_code buf CodeValBody; squash_keyword_param_values pos buf keywords; add_code buf CodeSpace; squash_params buf params; add_code buf CodeArrow; squash_exp_list pos buf e; add_code buf CodeSpace; squash_export_info buf export | ValObject obj -> add_code buf CodeValObject; squash_object pos buf obj | ValMap obj -> add_code buf CodeValMap; squash_map pos buf obj | ValCases cases -> squash_cases pos buf cases | ValVar (_, v) -> add_code buf CodeValVar; squash_var_info buf v; | ValDelayed { contents = ValValue v } -> squash_value pos buf v | ValDelayed { contents = ValStaticApply (node, v) } -> add_code buf CodeValStaticApply; squash_value pos buf node; add_code buf CodeSpace; squash_var buf v | ValRules _ | ValChannel _ | ValClass _ | ValOther _ as v -> let print_error buf = Format.fprintf buf "@[Non digestable value:@ @[%a@]@ Contact the OMake team at omake@@metaprl.org if you think this should be supported@]@." Omake_value_print.pp_print_value v in raise (Omake_value_type.OmakeFatalErr (pos, LazyError print_error)) end; add_code buf CodeEnd and squash_opt_value pos buf = function Some v -> add_code buf CodeSome; squash_value pos buf v | None -> add_code buf CodeNone and squash_values pos buf vl = match vl with [v] -> squash_value pos buf v | v :: vl -> squash_value pos buf v; add_code buf CodeSpace; squash_values pos buf vl | [] -> () and squash_param_values pos buf kargs = match kargs with (v, arg) :: kargs -> add_code buf CodeSpace; squash_var_info buf v; add_code buf CodeSpace; squash_value pos buf arg; squash_param_values pos buf kargs | [] -> () and squash_keyword_values pos buf kargs = match kargs with (v, arg) :: kargs -> add_code buf CodeSpace; squash_var buf v; add_code buf CodeSpace; squash_value pos buf arg; squash_keyword_values pos buf kargs | [] -> () and squash_keyword_param_values pos buf kargs = match kargs with (v, v_info, opt_arg) :: kargs -> add_code buf CodeSpace; squash_var buf v; add_code buf CodeSpace; squash_var_info buf v_info; add_code buf CodeSpace; squash_opt_value pos buf opt_arg; squash_keyword_param_values pos buf kargs | [] -> () and squash_object pos buf obj = Lm_symbol.SymbolTable.iter (fun x v -> add_code buf CodeBegin; squash_var buf x; add_code buf CodeArrow; squash_value pos buf v; add_code buf CodeEnd) (Omake_env.squash_object obj) and squash_map pos buf map = Omake_env.venv_map_iter (fun x v -> add_code buf CodeBegin; squash_value pos buf x; add_code buf CodeArrow; squash_value pos buf v; add_code buf CodeEnd) map and squash_case pos buf (x, v1, _x2, export) = add_code buf CodeCase; squash_var buf x; add_code buf CodeSpace; squash_value pos buf v1; add_code buf CodeSpace; squash_value pos buf v1; add_code buf CodeSpace; squash_export_info buf export; add_code buf CodeEnd and squash_cases pos buf cases = add_code buf CodeCases; List.iter (squash_case pos buf) cases; add_code buf CodeEnd (* * Commands. *) (* let squash_command_flag buf flag = *) (* let code = *) (* match flag with *) (* |Omake_command_type.QuietFlag -> *) (* CodeQuietFlag *) (* | AllowFailureFlag -> *) (* CodeAllowFailureFlag *) (* | AllowOutputFlag -> *) (* CodeAllowOutputFlag *) (* in *) (* add_code buf code *) (* let squash_command_flags buf flags = *) (* add_code buf CodeCommandFlags; *) (* List.iter (squash_command_flag buf) flags; *) (* add_code buf CodeEnd *) let squash_arg_string buf arg = match arg with | Omake_command_type.ArgString s -> add_code buf CodeArgString; Hash.add_string buf s | ArgData s -> add_code buf CodeArgData; Hash.add_string buf s let squash_arg buf arg = add_code buf CodeArg; List.iter (squash_arg_string buf) arg; add_code buf CodeEnd let squash_redirect buf chan = match chan with |Omake_shell_type.RedirectNode node -> add_code buf CodeRedirectNode; squash_node buf node | RedirectArg arg -> add_code buf CodeRedirectArg; squash_arg buf arg | RedirectNone -> add_code buf CodeRedirectNone let squash_argv buf argv = add_code buf CodeArgv; List.iter (squash_arg buf) argv; add_code buf CodeEnd let squash_command_env_item buf (v, arg) = add_code buf CodeCommandEnvItem; squash_var buf v; add_code buf CodeSpace; squash_arg buf arg; add_code buf CodeEnd let squash_command_env buf env = add_code buf CodeCommandEnv; List.iter (squash_command_env_item buf) env; add_code buf CodeEnd let squash_exe buf exe = match exe with |Omake_shell_type.CmdArg arg -> add_code buf CodeCmdArg; squash_arg buf arg | CmdNode node -> add_code buf CodeCmdNode; squash_node buf node let squash_pipe_op buf op = let code = match op with |Omake_shell_type.PipeAnd -> CodePipeAnd | PipeOr -> CodePipeOr | PipeSequence -> CodePipeSequence in add_code buf code let squash_pipe_command _pos buf (info : Omake_env.arg_cmd) = let { Omake_shell_type.cmd_env = env; cmd_exe = exe; cmd_argv = argv; cmd_stdin = stdin; cmd_stdout = stdout; cmd_stderr = stderr; cmd_append = append; _ } = info in add_code buf CodePipeCommand; squash_command_env buf env; add_code buf CodeSpace; squash_exe buf exe; add_code buf CodeSpace; squash_argv buf argv; add_code buf CodeSpace; squash_redirect buf stdin; add_code buf CodeSpace; squash_redirect buf stdout; add_code buf CodeSpace; Hash.add_bool buf stderr; add_code buf CodeSpace; Hash.add_bool buf append; add_code buf CodeEnd let squash_pipe_apply pos buf (info : Omake_env.arg_apply) = let {Omake_shell_type.apply_name = name; apply_args = args; apply_stdin = stdin; apply_stdout = stdout; apply_stderr = stderr; apply_append = append; _ } = info in add_code buf CodePipeApply; squash_var buf name; add_code buf CodeSpace; squash_values pos buf args; add_code buf CodeSpace; squash_redirect buf stdin; add_code buf CodeSpace; squash_redirect buf stdout; add_code buf CodeSpace; Hash.add_bool buf stderr; add_code buf CodeSpace; Hash.add_bool buf append; add_code buf CodeEnd let rec squash_pipe pos buf (pipe : Omake_env.arg_pipe) = (match pipe with PipeApply (_, info) -> squash_pipe_apply pos buf info | PipeCommand (_, info) -> squash_pipe_command pos buf info | PipeCond (_, op, pipe1, pipe2) -> add_code buf CodePipeCond; squash_pipe_op buf op; squash_pipe pos buf pipe1; squash_pipe pos buf pipe2 | PipeCompose (_, b, pipe1, pipe2) -> add_code buf CodePipeCompose; Hash.add_bool buf b; squash_pipe pos buf pipe1; squash_pipe pos buf pipe2 | PipeGroup (_, info) -> squash_pipe_group pos buf info | PipeBackground (_, pipe) -> add_code buf CodePipeBackground; squash_pipe pos buf pipe); add_code buf CodeEnd and squash_pipe_group pos buf info = let { Omake_shell_type.group_stdin = stdin; group_stdout = stdout; group_stderr = stderr; group_append = append; group_pipe = pipe } = info in add_code buf CodePipeGroup; squash_redirect buf stdin; add_code buf CodeSpace; squash_redirect buf stdout; add_code buf CodeSpace; Hash.add_bool buf stderr; add_code buf CodeSpace; Hash.add_bool buf append; add_code buf CodeSpace; squash_pipe pos buf pipe; add_code buf CodeEnd let squash_command_line pos buf (command : Omake_env.arg_command_inst) = match command with CommandPipe argv -> add_code buf CodePipe; squash_pipe pos buf argv; add_code buf CodeEnd | CommandEval e -> squash_exp_list pos buf e | CommandValues values -> squash_values pos buf values let squash_command pos buf (command : Omake_env.arg_command_line) = let {Omake_command_type.command_dir = dir; command_inst = inst; _ } = command in add_code buf CodeCommand; Hash.add_string buf (Omake_node.Dir.fullname dir); squash_command_line pos buf inst; add_code buf CodeEnd let squash_commands pos buf commands = add_code buf CodeCommands; List.iter (squash_command pos buf) commands; add_code buf CodeEnd (* * Get the digest of some commands. *) let digest_of_exp pos values e = let buf = Hash.create () in squash_values pos buf values; add_code buf CodeSpace; squash_exp pos buf e; Some (Hash.digest buf) let digest_of_commands pos commands = match commands with [] -> None | _ -> let buf = Hash.create () in let () = squash_commands pos buf commands in Some (Hash.digest buf) omake-0.10.3/src/env/omake_env.ml0000644000175000017500000033620313177364665015221 0ustar gerdgerd module TargetElem = struct type t = int * string * Omake_node_sig.node_kind let compare (h1,s1,k1) (h2,s2,k2) = if h1=h2 then let p1 = String.compare s1 s2 in if p1 = 0 then Pervasives.compare k1 k2 else p1 else h1-h2 let intern ((s1,k1) as key) = let h1 = Hashtbl.hash key in (h1,s1,k1) end module TargetMap = Lm_map.Make(TargetElem) (* * Command lists have source arguments. *) type command_info = { command_env : t; command_sources : Omake_node.Node.t list; command_values : Omake_value_type.t list; command_body : Omake_value_type.command list } (* * An implicit rule with a body. * * In an implicit rule, we compile the targets/sources * to wild patterns. *) and irule = { irule_loc : Lm_location.t; irule_multiple : Omake_value_type.rule_multiple; irule_targets : Lm_string_set.StringSet.t option; irule_patterns : Lm_wild.in_patt list; irule_locks : Omake_value_type.source_core Omake_value_type.source list; irule_sources : Omake_value_type.source_core Omake_value_type.source list; irule_scanners : Omake_value_type.source_core Omake_value_type.source list; irule_values : Omake_value_type.t list; irule_body : Omake_value_type.command list } (* * An implicit dependency. There is no body, but * it may have value dependencies. *) and inrule = { inrule_loc : Lm_location.t; inrule_multiple : Omake_value_type.rule_multiple; inrule_patterns : Lm_wild.in_patt list; inrule_locks : Omake_value_type.source_core Omake_value_type.source list; inrule_sources : Omake_value_type.source_core Omake_value_type.source list; inrule_scanners : Omake_value_type.source_core Omake_value_type.source list; inrule_values : Omake_value_type.t list } (* * Explicit rules. *) and erule = { rule_loc : Lm_location.t; rule_env : t; rule_target : Omake_node.Node.t; rule_effects : Omake_node.NodeSet.t; rule_locks : Omake_node.NodeSet.t; rule_sources : Omake_node.NodeSet.t; rule_scanners : Omake_node.NodeSet.t; rule_match : string option; rule_multiple : Omake_value_type.rule_multiple; rule_commands : command_info list } (* * A listing of all the explicit rules. * * explicit_targets : the collapsed rules for each explicit target * explicit_deps : the table of explicit rules that are just dependencies * explicit_rules : the table of all individual explicit rules * explicit_directories : the environment for each directory in the project *) and erule_info = { explicit_targets : erule Omake_node.NodeTable.t; explicit_deps : (Omake_node.NodeSet.t * Omake_node.NodeSet.t * Omake_node.NodeSet.t) Omake_node.NodeTable.t; (* locks, sources, scanners *) explicit_rules : erule Omake_node.NodeMTable.t; explicit_directories : t Omake_node.DirTable.t } (* * An ordering rule. * For now, this just defines an extra dependency * of the form: patt1 -> patt2 * This means that if a file depends on patt1, * then it also depends on patt2. *) and orule = { orule_loc : Lm_location.t; orule_name : Lm_symbol.t; orule_pattern : Lm_wild.in_patt; orule_sources : Omake_value_type.source_core list } and ordering_info = orule list and srule = { srule_loc : Lm_location.t; srule_static : bool; srule_env : t; srule_key : Omake_value_type.t; srule_deps : Omake_node.NodeSet.t; srule_vals : Omake_value_type.t list; srule_exp : Omake_ir.exp } and static_info = StaticRule of srule | StaticValue of Omake_value_type.obj (* * The environment contains three scopes: * 1. The dynamic scope * 2. The current object * 3. The static scope * Lookup occurs in that order, unless the variables * have been defined otherwise. * * Each function has its own static scope. * The dynamic scope comes from the caller. *) and t = { venv_dynamic : Omake_value_type.env; venv_this : Omake_value_type.obj; venv_static : Omake_value_type.env; venv_inner : venv_inner } and venv_inner = { venv_environ : string Lm_symbol.SymbolTable.t; venv_dir : Omake_node.Dir.t; venv_phony : Omake_node.NodeSet.t; venv_implicit_deps : inrule list; venv_implicit_rules : irule list; venv_options : Omake_options.t; venv_globals : venv_globals; venv_mount : Omake_node.Mount.t; venv_included_files : Omake_node.NodeSet.t } and venv_globals = { mutable venv_parent : (venv_globals * int) option; (* after a venv_fork this is the pointer to the source; it is set back to None when any of the versions is changed. The int is the version of the parent. *) mutable venv_version : int; (* increased after a change *) mutable venv_mutex : Lm_thread.Mutex.t; (* At present, the venv_parent/venv_version mechanism is only used to accelerate target_is_buildable{_proper}. If a forked venv is still identical to the original, this cache can be better updated in the parent (back propagation). TODO: another candidate for back propagation is the file cache. *) (* Execution service *) venv_exec : exec; (* File cache *) venv_cache : Omake_cache.t; (* Mounting functions *) venv_mount_info : Omake_node.mount_info; (* Values from handles *) venv_environments : t Lm_handle_table.t; (* The set of files we have ever read *) mutable venv_files : Omake_node.NodeSet.t; (* Save the environment for each directory in the project *) mutable venv_directories : t Omake_node.DirTable.t; mutable venv_excluded_directories : Omake_node.DirSet.t; (* All the phony targets we have ever generated *) mutable venv_phonies : Omake_node.PreNodeSet.t; (* Explicit rules are global *) mutable venv_explicit_rules : erule list; mutable venv_explicit_targets : erule Omake_node.NodeTable.t; mutable venv_explicit_new : erule list; (* Ordering rules *) mutable venv_ordering_rules : orule list; mutable venv_orders : Lm_string_set.StringSet.t; (* Static rules *) mutable venv_memo_rules : static_info Omake_value_util.ValueTable.t; (* Cached values for files *) mutable venv_ir_files : Omake_ir.t Omake_node.NodeTable.t; mutable venv_object_files : Omake_value_type.obj Omake_node.NodeTable.t; (* Cached values for static sections *) mutable venv_static_values : Omake_value_type.obj Lm_symbol.SymbolTable.t Omake_node.NodeTable.t; mutable venv_modified_values : Omake_value_type.obj Lm_symbol.SymbolTable.t Omake_node.NodeTable.t; (* Cached values for the target_is_buildable function *) (* This uses now a compression: we map directories to small integers target_dir. This mapping is implemented by venv_target_dirs. For every (candidate) target file we map the file name to two bitsets (buildable,non_buildable) enumerating the directories where the file can be built or not be built. *) mutable venv_target_dirs : target_dir Omake_node.DirTable.t; mutable venv_target_next_dir : target_dir; mutable venv_target_is_buildable : (Lm_bitset.t * Lm_bitset.t) TargetMap.t; mutable venv_target_is_buildable_proper : (Lm_bitset.t * Lm_bitset.t) TargetMap.t; (* The state right after Pervasives is evaluated *) mutable venv_pervasives_vars : Omake_ir.senv; mutable venv_pervasives_obj : Omake_value_type.obj } and target_dir = int (* * Type of execution servers. *) and pid = InternalPid of int | ExternalPid of int | ResultPid of int * t * Omake_value_type.t and exec = (arg_command_line, pid, Omake_value_type.t) Omake_exec.Exec.t (* * Execution service. *) and arg_command_inst = (Omake_ir.exp, arg_pipe, Omake_value_type.t) Omake_command_type.poly_command_inst and arg_command_line = (t, Omake_ir.exp, arg_pipe, Omake_value_type.t) Omake_command_type.poly_command_line and string_command_inst = (Omake_ir.exp, string_pipe, Omake_value_type.t) Omake_command_type.poly_command_inst and string_command_line = (t, Omake_ir.exp, string_pipe, Omake_value_type.t) Omake_command_type.poly_command_line and apply = t -> Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> (Lm_symbol.t * string) list -> Omake_value_type.t list -> int * t * Omake_value_type.t and value_cmd = (unit, Omake_value_type.t list, Omake_value_type.t list) Omake_shell_type.poly_cmd and value_apply = (Omake_value_type.t list, Omake_value_type.t list, apply) Omake_shell_type.poly_apply and value_group = (unit, Omake_value_type.t list, Omake_value_type.t list, Omake_value_type.t list, apply) Omake_shell_type.poly_group and value_pipe = (unit, Omake_value_type.t list, Omake_value_type.t list, Omake_value_type.t list, apply) Omake_shell_type.poly_pipe and arg_cmd = (Omake_command_type.arg Omake_shell_type.cmd_exe, Omake_command_type.arg, Omake_command_type.arg) Omake_shell_type.poly_cmd and arg_apply = (Omake_value_type.t, Omake_command_type.arg, apply) Omake_shell_type.poly_apply and arg_group = (Omake_command_type.arg Omake_shell_type.cmd_exe, Omake_command_type.arg, Omake_value_type.t, Omake_command_type.arg, apply) Omake_shell_type.poly_group and arg_pipe = (Omake_command_type.arg Omake_shell_type.cmd_exe, Omake_command_type.arg, Omake_value_type.t, Omake_command_type.arg, apply) Omake_shell_type.poly_pipe and string_cmd = (Omake_shell_type.simple_exe, string, string) Omake_shell_type.poly_cmd and string_apply = (Omake_value_type.t, string, apply) Omake_shell_type.poly_apply and string_group = (Omake_shell_type.simple_exe, string, Omake_value_type.t, string, apply) Omake_shell_type.poly_group and string_pipe = (Omake_shell_type.simple_exe, string, Omake_value_type.t, string, apply) Omake_shell_type.poly_pipe (* * Error during translation. *) exception Break of Lm_location.t * t type prim_fun_data = t -> Omake_value_type.pos -> Lm_location.t -> Omake_value_type.t list -> Omake_value_type.keyword_value list -> t * Omake_value_type.t type venv_runtime = { venv_channels : Lm_channel.t Lm_int_handle_table.t; mutable venv_primitives : prim_fun_data Lm_symbol.SymbolTable.t } (* * Command line parsing. *) type lexer = string -> int -> int -> int option type tok = TokString of Omake_value_type.t | TokToken of string | TokGroup of tok list (* * Inclusion scope is usually Pervasives, * but it may include everything in scope. *) type include_scope = IncludePervasives | IncludeAll (* * Full and partial applications. *) type partial_apply = FullApply of t * Omake_value_type.t list * Omake_value_type.keyword_value list | PartialApply of Omake_value_type.env * Omake_value_type.param_value list * Omake_value_type.keyword_param_value list * Omake_ir.param list * Omake_value_type.keyword_value list let venv_runtime : venv_runtime = { venv_channels = Lm_int_handle_table.create (); venv_primitives = Lm_symbol.SymbolTable.empty } (* * Now the stuff that is really global, not saved in venv. *) module IntCompare = struct type t = int let compare = (-) end;; module IntTable = Lm_map.LmMake (IntCompare);; (************************************************************************ * Access to the globals. * This actually performs some computation in 0.9.9 *) let venv_globals venv = venv.venv_inner.venv_globals let venv_protect globals f = Lm_thread.Mutex.lock globals.venv_mutex; try let r = f() in Lm_thread.Mutex.unlock globals.venv_mutex; r with | exn -> Lm_thread.Mutex.unlock globals.venv_mutex; raise exn let venv_synch venv f = let globals = venv_globals venv in venv_protect globals (fun () -> match globals.venv_parent with | Some(pglobals, pversion) -> venv_protect pglobals (fun () -> if pversion = pglobals.venv_version then f globals (Some pglobals) else ( globals.venv_parent <- None; f globals None ) ) | None -> f globals None ) let venv_incr_version venv f = (* At present, this function needs to be called when any change is done that may affect target_is_buildable(_proper), i.e. the addition of implicit, explicit or phony rules. *) let g = venv_globals venv in venv_protect g (fun () -> g.venv_version <- g.venv_version + 1; g.venv_parent <- None; f() ) (* * Map functions. *) let check_map_key = Omake_value_util.ValueCompare.check let venv_map_empty = Omake_value_util.ValueTable.empty let venv_map_add map pos v1 v2 = Omake_value_util.ValueTable.add map (check_map_key pos v1) v2 let venv_map_remove map pos v1 = Omake_value_util.ValueTable.remove map (check_map_key pos v1) let venv_map_find map pos v = try Omake_value_util.ValueTable.find map (check_map_key pos v) with Not_found -> raise (Omake_value_type.OmakeException (pos, UnboundValue v)) let venv_map_mem map pos v = Omake_value_util.ValueTable.mem map (check_map_key pos v) let venv_map_iter = Omake_value_util.ValueTable.iter let venv_map_map = Omake_value_util.ValueTable.mapi let venv_map_fold = Omake_value_util.ValueTable.fold let venv_map_length = Omake_value_util.ValueTable.cardinal (************************************************************************ * Printing. *) let rec pp_print_command buf command = match command with Omake_value_type.CommandSection (arg, _fv, e) -> Format.fprintf buf "@[section %a@ %a@]" Omake_value_print.pp_print_value arg Omake_ir_print.pp_print_exp_list e | CommandValue (_, _, v) -> Omake_ir_print.pp_print_string_exp buf v and pp_print_commands buf commands = List.iter (fun command -> Format.fprintf buf "@ %a" pp_print_command command) commands and pp_print_command_info buf info = let { command_env = venv; command_sources = sources; command_body = commands; _ } = info in Format.fprintf buf "@[@[{@ command_dir = %a;@ @[command_sources =%a@]@ @[command_body =%a@]@]@ }@]" (**) Omake_node.pp_print_dir venv.venv_inner.venv_dir Omake_node.pp_print_node_list sources pp_print_commands commands and pp_print_command_info_list buf infos = List.iter (fun info -> Format.fprintf buf "@ %a" pp_print_command_info info) infos and pp_print_rule buf erule = let { rule_target = target; rule_effects = effects; rule_locks = locks; rule_sources = sources; rule_scanners = scanners; rule_commands = commands; _ } = erule in Format.fprintf buf "@[@[rule {"; Format.fprintf buf "@ target = %a" Omake_node.pp_print_node target; Format.fprintf buf "@ @[effects =%a@]" Omake_node.pp_print_node_set effects; Format.fprintf buf "@ @[locks =%a@]" Omake_node.pp_print_node_set locks; Format.fprintf buf "@ @[sources =%a@]" Omake_node.pp_print_node_set sources; Format.fprintf buf "@ @[scanners =%a@]" Omake_node.pp_print_node_set scanners; Format.fprintf buf "@ @[commands =%a@]" pp_print_command_info_list commands; Format.fprintf buf "@]@ }@]" let pp_print_explicit_rules buf venv = Format.fprintf buf "@[Explicit rules:"; List.iter (fun erule -> Format.fprintf buf "@ %a" pp_print_rule erule) venv.venv_inner.venv_globals.venv_explicit_rules; Format.fprintf buf "@]" (************************************************************************ * Pipeline printing. *) (* * Token printing. *) let rec pp_print_tok buf tok = match tok with TokString v -> Omake_value_print.pp_print_value buf v | TokToken s -> Format.fprintf buf "$%s" s | TokGroup toks -> Format.fprintf buf "(%a)" pp_print_tok_list toks and pp_print_tok_list buf toks = match toks with [tok] -> pp_print_tok buf tok | tok :: toks -> pp_print_tok buf tok; Lm_printf.pp_print_char buf ' '; pp_print_tok_list buf toks | [] -> () let pp_print_simple_exe buf exe = match exe with Omake_shell_type.ExeString s -> Lm_printf.pp_print_string buf s | ExeQuote s -> Format.fprintf buf "\\%s" s | ExeNode node -> Omake_node.pp_print_node buf node (* * Pipes based on strings. *) module PrintString = struct type arg_command = string type arg_apply = Omake_value_type.t type arg_other = string type exe = Omake_shell_type.simple_exe let pp_print_arg_command = Omake_command_type.pp_arg_data_string let pp_print_arg_apply = Omake_value_print.pp_print_value let pp_print_arg_other = Omake_command_type.pp_arg_data_string let pp_print_exe = pp_print_simple_exe end;; module PrintStringPipe = Omake_shell_type.MakePrintPipe (PrintString);; module PrintStringv = struct type argv = string_pipe let pp_print_argv = PrintStringPipe.pp_print_pipe end;; module PrintStringCommand = Omake_command_type.MakePrintCommand (PrintStringv);; let pp_print_string_pipe = PrintStringPipe.pp_print_pipe let pp_print_string_command_inst = PrintStringCommand.pp_print_command_inst let pp_print_string_command_line = PrintStringCommand.pp_print_command_line let pp_print_string_command_lines = PrintStringCommand.pp_print_command_lines (* * Pipes based on arguments. *) module PrintArg = struct type arg_command = Omake_command_type.arg type arg_apply = Omake_value_type.t type arg_other = arg_command type exe = arg_command Omake_shell_type.cmd_exe let pp_print_arg_command = Omake_command_type.pp_print_arg let pp_print_arg_apply = Omake_value_print.pp_print_simple_value let pp_print_arg_other = pp_print_arg_command let pp_print_exe buf exe = match exe with Omake_shell_type.CmdArg arg -> pp_print_arg_command buf arg | CmdNode node -> Omake_node.pp_print_node buf node end;; module PrintArgPipe = Omake_shell_type.MakePrintPipe (PrintArg);; module PrintArgv = struct type argv = arg_pipe let pp_print_argv = PrintArgPipe.pp_print_pipe end;; module PrintArgCommand = Omake_command_type.MakePrintCommand (PrintArgv);; let pp_print_arg_pipe = PrintArgPipe.pp_print_pipe let pp_print_arg_command_inst = PrintArgCommand.pp_print_command_inst let pp_print_arg_command_line = PrintArgCommand.pp_print_command_line let pp_print_arg_command_lines = PrintArgCommand.pp_print_command_lines (************************************************************************ * Utilities. *) (* * Don't make command info if there are no commands. *) let make_command_info venv sources values body = match values, body with [], [] -> [] | _ -> [{ command_env = venv; command_sources = sources; command_values = values; command_body = body }] (* * Check if the commands are trivial. *) let commands_are_trivial commands = List.for_all (fun command -> command.command_body = []) commands (* * Multiple flags. *) let is_multiple_rule = function Omake_value_type.RuleMultiple | RuleScannerMultiple -> true | RuleSingle | RuleScannerSingle -> false (* let is_scanner_rule = function *) (* Omake_value_type.RuleScannerSingle *) (* | RuleScannerMultiple -> *) (* true *) (* | RuleSingle *) (* | RuleMultiple -> *) (* false *) let rule_kind = function Omake_value_type.RuleScannerSingle | RuleScannerMultiple -> Omake_value_type.RuleScanner | RuleSingle | RuleMultiple -> RuleNormal (************************************************************************ * Handles. *) let venv_add_environment venv = Lm_handle_table.add venv.venv_inner.venv_globals.venv_environments venv module Pos= Omake_pos.Make (struct let name = "Omake_env" end) let venv_find_environment venv pos hand = try Lm_handle_table.find venv.venv_inner.venv_globals.venv_environments hand with Not_found -> let pos = Pos.string_pos "venv_find_environment" pos in raise (Omake_value_type.OmakeException (pos, StringError "unbound environment")) (************************************************************************ * Channels. *) (* * Add a channel slot. *) let venv_add_index_channel index data = let channels = venv_runtime.venv_channels in let channel = Lm_int_handle_table.create_handle channels index in Lm_channel.set_id data index; Lm_int_handle_table.add channels channel data; channel let venv_add_channel _venv data = let channels = venv_runtime.venv_channels in let channel = Lm_int_handle_table.new_handle channels in let index = Lm_int_handle_table.int_of_handle channel in Lm_channel.set_id data index; Lm_int_handle_table.add channels channel data; channel let add_channel file kind mode binary fd = Lm_channel.create file kind mode binary (Some fd) let venv_stdin = venv_add_index_channel 0 (add_channel "" Lm_channel.PipeChannel Lm_channel.InChannel false Unix.stdin) let venv_stdout = venv_add_index_channel 1 (add_channel "" Lm_channel.PipeChannel Lm_channel.OutChannel false Unix.stdout) let venv_stderr = venv_add_index_channel 2 (add_channel "" Lm_channel.PipeChannel Lm_channel.OutChannel false Unix.stderr) (* * A formatting channel. *) let venv_add_formatter_channel _venv fmt = let channels = venv_runtime.venv_channels in let fd = Lm_channel.create "formatter" Lm_channel.FileChannel Lm_channel.OutChannel true None in let channel = Lm_int_handle_table.new_handle channels in let index = Lm_int_handle_table.int_of_handle channel in let reader _s _off _len = raise (Unix.Unix_error (Unix.EINVAL, "formatter-channel", "")) in let writer s off len = Format.pp_print_string fmt (Bytes.to_string (Bytes.sub s off len)); len in Lm_channel.set_id fd index; Lm_channel.set_io_functions fd reader writer; Lm_int_handle_table.add channels channel fd; channel (* * Get the channel. *) let venv_channel_data channel = (* Standard channels are always available *) if Lm_int_handle_table.int_of_handle channel <= 2 then Lm_int_handle_table.find_any venv_runtime.venv_channels channel else Lm_int_handle_table.find venv_runtime.venv_channels channel (* * When a channel is closed, close the buffers too. *) let venv_close_channel _venv _pos channel = try let fd = venv_channel_data channel in Lm_channel.close fd; Lm_int_handle_table.remove venv_runtime.venv_channels channel with Not_found -> (* Fail silently *) () (* * Get the channel. *) let venv_find_channel _venv pos channel = let pos = Pos.string_pos "venv_find_in_channel" pos in try venv_channel_data channel with Not_found -> raise (Omake_value_type.OmakeException (pos, StringError "channel is closed")) (* * Finding by identifiers. *) let venv_find_channel_by_channel _venv pos fd = let index, _, _, _ = Lm_channel.info fd in try Lm_int_handle_table.find_value venv_runtime.venv_channels index fd with Not_found -> raise (Omake_value_type.OmakeException (pos, StringError "channel is closed")) let venv_find_channel_by_id _venv pos index = try Lm_int_handle_table.find_any_handle venv_runtime.venv_channels index with Not_found -> raise (Omake_value_type.OmakeException (pos, StringError "channel is closed")) (************************************************************************ * Primitive values. *) (* * Allocate a function primitive. *) let venv_add_prim_fun _venv name data = venv_runtime.venv_primitives <- Lm_symbol.SymbolTable.add venv_runtime.venv_primitives name data; name let debug_scanner = Lm_debug.create_debug (**) { debug_name = "scanner"; debug_description = "Display debugging information for scanner selection"; debug_value = false } let debug_implicit = Lm_debug.create_debug (**) { debug_name = "implicit"; debug_description = "Display debugging information for implicit rule selection"; debug_value = false } (* * Debug file database (.omc files). *) let debug_db = Lm_db.debug_db (* * Look up the primitive value if we haven't seen it already. *) let venv_apply_prim_fun name venv pos loc args = let f = try Lm_symbol.SymbolTable.find venv_runtime.venv_primitives name with Not_found -> raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, UnboundVar name)) in f venv pos loc args (************************************************************************ * Target cache. * * To keep this up-to-date, entries are added for explicit targets, * and the cache is flushed whenever an implicit rule is added. *) let lookup_target_dir_in g dir = try Omake_node.DirTable.find g.venv_target_dirs dir with | Not_found -> let tdir = g.venv_target_next_dir in g.venv_target_next_dir <- tdir+1; let tab = Omake_node.DirTable.add g.venv_target_dirs dir tdir in g.venv_target_dirs <- tab; tdir let venv_lookup_target_dir venv dir = venv_synch venv (fun globals pglobals_opt -> match pglobals_opt with | Some pglobals -> let tdir = lookup_target_dir_in pglobals dir in globals.venv_target_next_dir <- pglobals.venv_target_next_dir; globals.venv_target_dirs <- pglobals.venv_target_dirs; tdir | None -> lookup_target_dir_in globals dir ) let squeeze_phony = (* This is OK because whenever we add a phony target we flush the cache *) function | Omake_node_sig.NodePhony -> Omake_node_sig.NodeNormal | other -> other let venv_find_target_is_buildable_exn venv target_dir file node_kind = let node_kind = squeeze_phony node_kind in let g = venv_globals venv in let ikey = TargetElem.intern (file,node_kind) in let (bset,nonbset) = TargetMap.find ikey g.venv_target_is_buildable in Lm_bitset.is_set bset target_dir || ( if not(Lm_bitset.is_set nonbset target_dir) then raise Not_found; false ) let venv_find_target_is_buildable_multi venv file node_kind = let node_kind = squeeze_phony node_kind in let g = venv_globals venv in let ikey = TargetElem.intern (file,node_kind) in let (bset,nonbset) = try TargetMap.find ikey g.venv_target_is_buildable with | Not_found -> (Lm_bitset.create(), Lm_bitset.create()) in (fun target_dir -> Lm_bitset.is_set bset target_dir || ( if not(Lm_bitset.is_set nonbset target_dir) then raise Not_found; false ) ) let venv_find_target_is_buildable_proper_exn venv target_dir file node_kind = let node_kind = squeeze_phony node_kind in let g = venv_globals venv in let ikey = TargetElem.intern (file,node_kind) in let (bset,nonbset) = TargetMap.find ikey g.venv_target_is_buildable_proper in Lm_bitset.is_set bset target_dir || ( if not(Lm_bitset.is_set nonbset target_dir) then raise Not_found; false ) let add_target_to m target_dir file node_kind flag = let node_kind = squeeze_phony node_kind in let ikey = TargetElem.intern (file,node_kind) in let (bset,nonbset) = try TargetMap.find ikey m with Not_found -> (Lm_bitset.create(), Lm_bitset.create()) in let (bset',nonbset') = if flag then (Lm_bitset.set bset target_dir, nonbset) else (bset, Lm_bitset.set nonbset target_dir) in TargetMap.add ikey (bset',nonbset') m let venv_add_target_is_buildable venv target_dir file node_kind flag = let add g = let tab = add_target_to g.venv_target_is_buildable target_dir file node_kind flag in g.venv_target_is_buildable <- tab in venv_synch venv (fun globals pglobals_opt -> match pglobals_opt with | Some pglobals -> add pglobals; globals.venv_target_is_buildable <- pglobals.venv_target_is_buildable | None -> add globals ) let venv_add_target_is_buildable_multi venv file node_kind tdirs_pos tdirs_neg = let node_kind = squeeze_phony node_kind in let add g = let ikey = TargetElem.intern (file,node_kind) in let (bset,nonbset) = try TargetMap.find ikey g.venv_target_is_buildable with Not_found -> (Lm_bitset.create(), Lm_bitset.create()) in let bset' = Lm_bitset.set_multiple bset tdirs_pos in let nonbset' = Lm_bitset.set_multiple nonbset tdirs_neg in let tab = TargetMap.add ikey (bset',nonbset') g.venv_target_is_buildable in g.venv_target_is_buildable <- tab in venv_synch venv (fun globals pglobals_opt -> match pglobals_opt with | Some pglobals -> add pglobals; globals.venv_target_is_buildable <- pglobals.venv_target_is_buildable | None -> add globals ) let venv_add_target_is_buildable_proper venv target_dir file node_kind flag = let add g = let tab = add_target_to g.venv_target_is_buildable_proper target_dir file node_kind flag in g.venv_target_is_buildable_proper <- tab in venv_synch venv (fun globals pglobals_opt -> match pglobals_opt with | Some pglobals -> add pglobals; globals.venv_target_is_buildable_proper <- pglobals.venv_target_is_buildable_proper | None -> add globals ) let venv_add_explicit_targets venv rules = venv_incr_version venv (fun () -> let globals = venv.venv_inner.venv_globals in let { venv_target_is_buildable = cache; venv_target_is_buildable_proper = cache_proper; _ } = globals in let add cache erule = let dir = Omake_node.Node.dir erule.rule_target in let tdir = lookup_target_dir_in globals dir in let file = Omake_node.Node.tail erule.rule_target in let nkind = Omake_node.Node.kind erule.rule_target in add_target_to cache tdir file nkind true in let cache = List.fold_left add cache rules in let cache_proper = List.fold_left add cache_proper rules in globals.venv_target_is_buildable <- cache; globals.venv_target_is_buildable_proper <- cache_proper ) let venv_flush_target_cache venv = venv_incr_version venv (fun () -> let globals = venv.venv_inner.venv_globals in globals.venv_target_is_buildable <- TargetMap.empty; globals.venv_target_is_buildable_proper <- TargetMap.empty ) (* * Save explicit rules. *) let venv_save_explicit_rules venv _loc rules = let globals = venv.venv_inner.venv_globals in globals.venv_explicit_new <- List.rev_append rules globals.venv_explicit_new; venv_add_explicit_targets venv rules (* * Add an explicit dependency. *) let venv_add_explicit_dep venv loc target source = let erule = { rule_loc = loc; rule_env = venv; rule_target = target; rule_effects = Omake_node.NodeSet.singleton target; rule_sources = Omake_node.NodeSet.singleton source; rule_locks = Omake_node.NodeSet.empty; rule_scanners = Omake_node.NodeSet.empty; rule_match = None; rule_multiple = RuleSingle; rule_commands = [] } in ignore (venv_save_explicit_rules venv loc [erule]) (* * Phony names. *) let venv_add_phony venv loc names = if names = [] then venv else let inner = venv.venv_inner in let { venv_dir = dir; venv_phony = phony; _ } = inner in let globals = venv_globals venv in let phonies = globals.venv_phonies in let phony, phonies = List.fold_left (fun (phony, phonies) name -> let name = match name with Omake_value_type.TargetNode _ -> raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, StringError ".PHONY arguments should be names")) | TargetString s -> s in let gnode = Omake_node.Node.create_phony_global name in let dnode = Omake_node.Node.create_phony_dir dir name in let phony = Omake_node.NodeSet.add phony dnode in let phonies = Omake_node.PreNodeSet.add phonies (Omake_node.Node.dest gnode) in let phonies = Omake_node.PreNodeSet.add phonies (Omake_node.Node.dest dnode) in venv_add_explicit_dep venv loc gnode dnode; phony, phonies) (phony, phonies) names in let inner = { inner with venv_phony = phony } in let venv = { venv with venv_inner = inner } in venv_incr_version venv (fun () -> ()); globals.venv_phonies <- phonies; venv (************************************************************************ * Static values. *) (* * Static loading. *) module type StaticSig = sig type in_handle type out_handle (* * Open a file. The Omake_node.Node.t is the name of the _source_ file, * not the .omc file. We'll figure out where the .omc file * goes on our own. Raises Not_found if the source file * can't be found. * The implementation will make sure all the locking/unlocking is done properly. *) val read : t -> Omake_node.Node.t -> (in_handle -> 'a) -> 'a val rewrite : in_handle -> (out_handle -> 'a) -> 'a (* * Fetch the two kinds of entries. *) val find_ir : in_handle -> Omake_ir.t val find_object : in_handle -> Omake_value_type.obj val get_ir : out_handle -> Omake_ir.t val get_object : out_handle -> Omake_value_type.obj (* * Add the two kinds of entries. *) val add_ir : out_handle -> Omake_ir.t -> unit val add_object : out_handle -> Omake_value_type.obj -> unit end (* * For static values, we access the db a bit more directly *) module type InternalStaticSig = sig include StaticSig val write : t -> Omake_node.Node.t -> (out_handle -> 'a) -> 'a val find_values : in_handle -> Omake_value_type.obj Lm_symbol.SymbolTable.t val add_values : out_handle -> Omake_value_type.obj Lm_symbol.SymbolTable.t -> unit end module Static : InternalStaticSig = struct (* * A .omc file. *) type handle = { db_file : Unix.file_descr option; db_name : Omake_node.Node.t; db_digest : string; db_env : t; db_flush_ir : bool; db_flush_static : bool } type in_handle = handle type out_handle = handle (* * Tags for the various kinds of entries. *) let ir_tag = 0, Lm_db.HostIndependent let object_tag = 1, Lm_db.HostDependent let values_tag = 2, Lm_db.HostDependent (************************************************************************ * Operations. *) (* * Open a file. The Omake_node.Node.t is the name of the _source_ file, * not the .omc file. We'll figure out where the .omc file * goes on our own. *) let create_mode mode venv source = (* Get the source digest *) let cache = venv.venv_inner.venv_globals.venv_cache in let digest = match Omake_cache.stat cache source with Some (_,digest) -> digest | None -> raise Not_found in (* * Open the result file. The lock_cache_file function * will try to use the target directory first, and * fall back to ~/.omake/cache if that is not writable. *) let source_name = Omake_node.Node.absname source in let dir = Filename.dirname source_name in let name = Filename.basename source_name in let name = if Filename.check_suffix name ".om" then Filename.chop_suffix name ".om" else name in let name = name ^ ".omc" in let target_fd = try let target_name, target_fd = Omake_state.get_cache_file dir name in if !debug_db then Lm_printf.eprintf "@[Omake_db.create:@ %a --> %s@]@." Omake_node.pp_print_node source target_name; Unix.set_close_on_exec target_fd; Omake_state.lock_file target_fd mode; Some target_fd with Unix.Unix_error _ | Failure _ -> Lm_printf.eprintf "@[OMake warning: could not create and/or lock a cache file for@ %s@]@." source_name; None in { db_file = target_fd; db_name = source; db_digest = digest; db_env = venv; db_flush_ir = Omake_options.opt_flush_include venv.venv_inner.venv_options; db_flush_static = Omake_options.opt_flush_static venv.venv_inner.venv_options; } (* * Restart with a write lock. *) let rewrite info f = match info.db_file with Some fd -> ignore (Unix.lseek fd 0 Unix.SEEK_SET: int); Omake_state.lock_file fd Unix.F_ULOCK; Omake_state.lock_file fd Unix.F_LOCK; let finish () = ignore (Unix.lseek fd 0 Unix.SEEK_SET: int); Omake_state.lock_file fd Unix.F_ULOCK; Omake_state.lock_file fd Unix.F_RLOCK in begin try let result = f info in finish (); result with exn -> finish (); raise exn end | None -> f info (* * Close the file. *) let close info = match info with { db_file = Some fd; db_name = name ; _} -> if !debug_db then Lm_printf.eprintf "Omake_db.close: %a@." Omake_node.pp_print_node name; Unix.close fd | { db_file = None ; _} -> () let perform mode venv source f = let info = create_mode mode venv source in try let result = f info in close info; result with exn -> close info; raise exn let read venv source f = perform Unix.F_RLOCK venv source f let write venv source f = perform Unix.F_LOCK venv source f (* * Add the three kinds of entries. *) let add_ir info ir = match info with { db_file = Some fd; db_name = name; db_digest = digest; db_env = _venv ; _} -> if !debug_db then Lm_printf.eprintf "Omake_db.add_ir: %a@." Omake_node.pp_print_node name; Lm_db.add fd (Omake_node.Node.absname name) ir_tag Omake_magic.ir_magic digest ir | { db_file = None ; _} -> () let add_object info obj = match info with { db_file = Some fd; db_name = name; db_digest = digest; db_env = _venv ; _} -> if !debug_db then Lm_printf.eprintf "Omake_db.add_object: %a@." Omake_node.pp_print_node name; Lm_db.add fd (Omake_node.Node.absname name) object_tag Omake_magic.obj_magic digest obj | { db_file = None ; _} -> () let add_values info obj = match info with { db_file = Some fd; db_name = name; db_digest = digest; db_env = _venv ; _} -> if !debug_db then Lm_printf.eprintf "Omake_db.add_values: %a@." Omake_node.pp_print_node name; Lm_db.add fd (Omake_node.Node.absname name) values_tag Omake_magic.obj_magic digest obj | { db_file = None ; _} -> () (* * Fetch the three kinds of entries. *) let find_ir = function { db_file = Some fd; db_name = name; db_digest = digest; db_flush_ir = false ; _} -> if !debug_db then Lm_printf.eprintf "Omake_db.find_ir: finding: %a@." Omake_node.pp_print_node name; let ir = Lm_db.find fd (Omake_node.Node.absname name) ir_tag Omake_magic.ir_magic digest in if !debug_db then Lm_printf.eprintf "Omake_db.find_ir: found: %a@." Omake_node.pp_print_node name; ir | { db_file = None ; _} | { db_flush_ir = true ; _} -> raise Not_found let find_object = function { db_file = Some fd; db_name = name; db_digest = digest; db_flush_ir = false; db_flush_static = false ; _} -> if !debug_db then Lm_printf.eprintf "Omake_db.find_object: finding: %a@." Omake_node.pp_print_node name; let obj = Lm_db.find fd (Omake_node.Node.absname name) object_tag Omake_magic.obj_magic digest in if !debug_db then Lm_printf.eprintf "Omake_db.find_object: found: %a@." Omake_node.pp_print_node name; obj | { db_file = None ; _} | { db_flush_ir = true ;_} | { db_flush_static = true ; _} -> raise Not_found let find_values = function { db_file = Some fd; db_name = name; db_digest = digest; db_flush_ir = false; db_flush_static = false ; _} -> if !debug_db then Lm_printf.eprintf "Omake_db.find_values: finding: %a@." Omake_node.pp_print_node name; let obj = Lm_db.find fd (Omake_node.Node.absname name) values_tag Omake_magic.obj_magic digest in if !debug_db then Lm_printf.eprintf "Omake_db.find_values: found: %a@." Omake_node.pp_print_node name; obj | { db_file = None ; _} | { db_flush_ir = true ; _} | { db_flush_static = true ; _} -> raise Not_found let get_ir = find_ir let get_object = find_object end;; (* * Cached object files. *) let venv_find_ir_file_exn venv node = Omake_node.NodeTable.find venv.venv_inner.venv_globals.venv_ir_files node let venv_add_ir_file venv node obj = let globals = venv.venv_inner.venv_globals in globals.venv_ir_files <- Omake_node.NodeTable.add globals.venv_ir_files node obj let venv_find_object_file_exn venv node = Omake_node.NodeTable.find venv.venv_inner.venv_globals.venv_object_files node let venv_add_object_file venv node obj = let globals = venv.venv_inner.venv_globals in globals.venv_object_files <- Omake_node.NodeTable.add globals.venv_object_files node obj (************************************************************************ * Variables. *) (* * Default empty object. *) let venv_empty_object = Lm_symbol.SymbolTable.empty (* * For variables, try to look them up as 0-arity functions first. *) let venv_find_var_private_exn venv v = Lm_symbol.SymbolTable.find venv.venv_static v let venv_find_var_dynamic_exn venv v = Lm_symbol.SymbolTable.find venv.venv_dynamic v let venv_find_var_protected_exn venv v = try Lm_symbol.SymbolTable.find venv.venv_this v with Not_found -> try Lm_symbol.SymbolTable.find venv.venv_dynamic v with Not_found -> try Lm_symbol.SymbolTable.find venv.venv_static v with Not_found -> ValString (Lm_symbol.SymbolTable.find venv.venv_inner.venv_environ v) let venv_find_var_global_exn venv v = try Lm_symbol.SymbolTable.find venv.venv_dynamic v with Not_found -> try Lm_symbol.SymbolTable.find venv.venv_this v with Not_found -> try Lm_symbol.SymbolTable.find venv.venv_static v with Not_found -> ValString (Lm_symbol.SymbolTable.find venv.venv_inner.venv_environ v) let venv_find_var_exn venv v = match v with Omake_ir.VarPrivate (_, v) -> venv_find_var_private_exn venv v | VarThis (_, v) -> venv_find_var_protected_exn venv v | VarVirtual (_, v) -> venv_find_var_dynamic_exn venv v | VarGlobal (_, v) -> venv_find_var_global_exn venv v let venv_get_var venv pos v = try venv_find_var_exn venv v with Not_found -> let pos = Pos.string_pos "venv_get_var" pos in raise (Omake_value_type.OmakeException (pos, UnboundVarInfo v)) let venv_find_var venv pos loc v = try venv_find_var_exn venv v with Not_found -> let pos = Pos.string_pos "venv_find_var" (Pos.loc_pos loc pos) in raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, UnboundVarInfo v)) let venv_find_object_or_empty venv v = try match venv_find_var_exn venv v with ValObject obj -> obj | _ -> venv_empty_object with Not_found -> venv_empty_object let venv_defined venv v = let { venv_this = this; venv_static = static; venv_dynamic = dynamic; _ } = venv in match v with Omake_ir.VarPrivate (_, v) -> Lm_symbol.SymbolTable.mem static v | VarVirtual (_, v) -> Lm_symbol.SymbolTable.mem dynamic v | VarThis (_, v) | VarGlobal (_, v) -> Lm_symbol.SymbolTable.mem this v || Lm_symbol.SymbolTable.mem dynamic v || Lm_symbol.SymbolTable.mem static v (* * Adding to variable environment. * Add to the current object and the static scope. *) let venv_add_var venv v s = let { venv_this = this; venv_static = static; venv_dynamic = dynamic; _ } = venv in match v with Omake_ir.VarPrivate (_, v) -> { venv with venv_static = Lm_symbol.SymbolTable.add static v s } | VarVirtual (_, v) -> { venv with venv_dynamic = Lm_symbol.SymbolTable.add dynamic v s } | VarThis (_, v) -> { venv with venv_this = Lm_symbol.SymbolTable.add this v s; venv_static = Lm_symbol.SymbolTable.add static v s } | VarGlobal (_, v) -> { venv with venv_dynamic = Lm_symbol.SymbolTable.add dynamic v s; venv_static = Lm_symbol.SymbolTable.add static v s } (* * Add the arguments given an environment. *) let rec venv_add_keyword_args pos venv keywords kargs = match keywords, kargs with (v1, v_info, opt_arg) :: keywords_tl, (v2, arg) :: kargs_tl -> let i = Lm_symbol.compare v1 v2 in if i = 0 then venv_add_keyword_args pos (venv_add_var venv v_info arg) keywords_tl kargs_tl else if i < 0 then match opt_arg with Some arg -> venv_add_keyword_args pos (venv_add_var venv v_info arg) keywords_tl kargs | None -> raise (Omake_value_type.OmakeException (pos, StringVarError ("keyword argument is required", v1))) else raise (Omake_value_type.OmakeException (pos, StringVarError ("no such keyword", v2))) | (v1, _, None) :: _, [] -> raise (Omake_value_type.OmakeException (pos, StringVarError ("keyword argument is required", v1))) | (_, v_info, Some arg) :: keywords_tl, [] -> venv_add_keyword_args pos (venv_add_var venv v_info arg) keywords_tl kargs | [], [] -> venv | [], (v2, _) :: _ -> raise (Omake_value_type.OmakeException (pos, StringVarError ("no such keyword", v2))) let venv_add_args venv pos loc static params args keywords kargs = let venv = { venv with venv_static = static } in let venv = venv_add_keyword_args pos venv keywords kargs in let len1 = List.length params in let len2 = List.length args in let () = if len1 <> len2 then raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, ArityMismatch (ArityExact len1, len2))) in List.fold_left2 venv_add_var venv params args (* * Add the arguments to the given static environment. *) let venv_with_args venv pos loc params args keywords kargs = venv_add_args venv pos loc venv.venv_static params args keywords kargs (* * Curried-applications. * * XXX: this needs to be checked, and performance improved too. * * Here is the idea: * * - Given a normal arg * + add the value to the env * + if params = [] then call the function * - Given a keyword arg * + if the keyword is valid here, add it to the env, subtract from keywords * + if not valid here, add to pending kargs *) let rec collect_merge_kargs pos rev_kargs kargs1 kargs2 = match kargs1, kargs2 with ((v1, _) as karg1) :: kargs1_tl, ((v2, _) as karg2) :: kargs2_tl -> let i = Lm_symbol.compare v1 v2 in if i = 0 then raise (Omake_value_type.OmakeException (pos, StringVarError ("duplicate keyword", v1))) else if i < 0 then collect_merge_kargs pos (karg1 :: rev_kargs) kargs1_tl kargs2 else collect_merge_kargs pos (karg2 :: rev_kargs) kargs1 kargs2_tl | [], kargs | kargs, [] -> List.rev_append rev_kargs kargs let merge_kargs pos kargs1 kargs2 = match kargs1, kargs2 with [], kargs | kargs, [] -> kargs | _ -> collect_merge_kargs pos [] kargs1 kargs2 let add_partial_args venv args = List.fold_left (fun venv (v, arg) -> venv_add_var venv v arg) venv args let rec apply_curry_args pos venv skipped_kargs params args = match params, args with [], _ -> venv, args, List.rev skipped_kargs | _, [] -> raise (Omake_value_type.OmakeException (pos, ArityMismatch (ArityExact (List.length params), 0))) | v :: params, arg :: args -> apply_curry_args pos (venv_add_var venv v arg) skipped_kargs params args let rec venv_add_curry_args pos venv params args keywords skipped_kargs kargs = match keywords, kargs with (v1, v_info, opt_arg) :: keywords_tl, ((v2, arg) as karg) :: kargs_tl -> let i = Lm_symbol.compare v1 v2 in if i = 0 then venv_add_curry_args pos (venv_add_var venv v_info arg) params args keywords_tl skipped_kargs kargs_tl else if i < 0 then match opt_arg with Some arg -> venv_add_curry_args pos (venv_add_var venv v_info arg) params args keywords_tl skipped_kargs kargs | None -> raise (Omake_value_type.OmakeException (pos, StringVarError ("keyword argument is required", v1))); else venv_add_curry_args pos venv params args keywords (karg :: skipped_kargs) kargs_tl | (v1, _, None) :: _, [] -> raise (Omake_value_type.OmakeException (pos, StringVarError ("keyword argument is required", v1))) | (_, v_info, Some arg) :: keywords_tl, [] -> venv_add_curry_args pos (venv_add_var venv v_info arg) params args keywords_tl skipped_kargs kargs | [], karg :: kargs_tl -> venv_add_curry_args pos venv params args keywords (karg :: skipped_kargs) kargs_tl | [], [] -> apply_curry_args pos venv skipped_kargs params args let venv_add_curry_args venv pos _loc static pargs params args keywords kargs1 kargs2 = let venv = { venv with venv_static = static } in let venv = add_partial_args venv pargs in venv_add_curry_args pos venv params args keywords [] (merge_kargs pos kargs1 kargs2) (* * Also provide a form for partial applications. *) let rec add_partial_keywords pos venv = function (v, _, None) :: _ -> raise (Omake_value_type.OmakeException (pos, StringVarError ("keyword argument is required", v))) | (_, v_info, Some arg) :: keywords_tl -> add_partial_keywords pos (venv_add_var venv v_info arg) keywords_tl | [] -> venv let rec apply_partial_args venv pos loc static env skipped_keywords keywords skipped_kargs params args = match params, args with [], _ -> let venv = { venv with venv_static = static } in let venv = add_partial_args venv env in let venv = add_partial_keywords pos venv skipped_keywords in let venv = add_partial_keywords pos venv keywords in FullApply (venv, args, List.rev skipped_kargs) | _, [] -> PartialApply (static, env, List.rev_append skipped_keywords keywords, params, List.rev skipped_kargs) | v :: params, arg :: args -> apply_partial_args venv pos loc static ((v, arg) :: env) skipped_keywords keywords skipped_kargs params args let rec venv_add_partial_args venv pos loc static env params args skipped_keywords keywords skipped_kargs kargs = match keywords, kargs with ((v1, v_info, _) as key) :: keywords_tl, ((v2, arg) as karg) :: kargs_tl -> let i = Lm_symbol.compare v1 v2 in if i = 0 then venv_add_partial_args venv pos loc static ((v_info, arg) :: env) params args skipped_keywords keywords_tl skipped_kargs kargs_tl else if i < 0 then venv_add_partial_args venv pos loc static env params args (key :: skipped_keywords) keywords_tl skipped_kargs kargs else venv_add_partial_args venv pos loc static env params args skipped_keywords keywords (karg :: skipped_kargs) kargs_tl | key :: keywords_tl, [] -> venv_add_partial_args venv pos loc static env params args (key :: skipped_keywords) keywords_tl skipped_kargs kargs | [], karg :: kargs_tl -> venv_add_partial_args venv pos loc static env params args skipped_keywords keywords (karg :: skipped_kargs) kargs_tl | [], [] -> apply_partial_args venv pos loc static env skipped_keywords keywords skipped_kargs params args let venv_add_partial_args venv pos loc static pargs params args keywords kargs1 kargs2 = venv_add_partial_args venv pos loc static pargs params args [] keywords [] (merge_kargs pos kargs1 kargs2) let venv_with_partial_args venv env args = let venv = { venv with venv_static = env } in add_partial_args venv args (* * The system environment. *) let venv_environment venv = venv.venv_inner.venv_environ let venv_getenv venv v = Lm_symbol.SymbolTable.find venv.venv_inner.venv_environ v let venv_setenv venv v x = { venv with venv_inner = { venv.venv_inner with venv_environ = Lm_symbol.SymbolTable.add venv.venv_inner.venv_environ v x } } let venv_unsetenv venv v = { venv with venv_inner = { venv.venv_inner with venv_environ = Lm_symbol.SymbolTable.remove venv.venv_inner.venv_environ v } } let venv_defined_env venv v = Lm_symbol.SymbolTable.mem venv.venv_inner.venv_environ v let venv_options (venv : t) : Omake_options.t = venv.venv_inner.venv_options let venv_with_options venv (options : Omake_options.t) : t = { venv with venv_inner = { venv.venv_inner with venv_options = options } } let venv_set_options_aux venv loc pos argv = let argv = Array.of_list argv in let add_unknown _options s = raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, StringStringError ("unknown option", s))) in let options_spec = Lm_arg.StrictOptions, (**) ["Make options", Omake_options.options_spec; "Output options", Omake_options.output_spec] in let options = try Lm_arg.fold_argv argv options_spec venv.venv_inner.venv_options add_unknown "Generic system builder" with Lm_arg.BogusArg s -> raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, StringError s)) in venv_with_options venv options let venv_set_options venv loc pos argv = venv_set_options_aux venv loc pos ("omake" :: argv) (************************************************************************ * Manipulating static objects. *) (* * Static values. Load the values from the file * if necessary. Raises Not_found if the object has not already * been loaded. *) let venv_find_static_object venv node v = let globals = venv.venv_inner.venv_globals in let static = globals.venv_static_values in let table = try Omake_node.NodeTable.find static node with Not_found -> (* Load it from the file *) let table = Static.read venv node Static.find_values in globals.venv_static_values <- Omake_node.NodeTable.add static node table; table in Lm_symbol.SymbolTable.find table v (* * Define a static var. * Save the object on the modified list so it will get * written back to the file. *) let venv_add_static_object venv node key obj = let globals = venv.venv_inner.venv_globals in let { venv_static_values = static; venv_modified_values = modified; _ } = globals in let table = try Omake_node.NodeTable.find static node with Not_found -> Lm_symbol.SymbolTable.empty in let table = Lm_symbol.SymbolTable.add table key obj in globals.venv_static_values <- Omake_node.NodeTable.add static node table; globals.venv_modified_values <- Omake_node.NodeTable.add modified node table (* * Inline the static variables into the current environment. *) let venv_include_static_object venv obj = let { venv_dynamic = dynamic ; _} = venv in let dynamic = Lm_symbol.SymbolTable.fold Lm_symbol.SymbolTable.add dynamic obj in { venv with venv_dynamic = dynamic } (* * Save the modified values. *) let venv_save_static_values venv = let globals = venv.venv_inner.venv_globals in Omake_node.NodeTable.iter (fun node table -> try Static.write venv node (fun fd -> Static.add_values fd table) with Not_found -> ()) globals.venv_modified_values; globals.venv_modified_values <- Omake_node.NodeTable.empty (************************************************************************ * Methods and objects. *) (* * Create a path when fetching fields, so that we * can hoist the exports from a method call. *) (* let raise_field_error mode pos loc v = *) (* let print_error buf = *) (* Format.fprintf buf "@[Accessing %s field: %a@ The variable was defined at the following location@ %a@]" (\**\) *) (* mode *) (* Lm_symbol.pp_print_symbol v *) (* Lm_location.pp_print_location loc *) (* in *) (* raise (Omake_value_type.OmakeException (pos, LazyError print_error)) *) (* let rec squash_path_info path info = *) (* match path with *) (* |Omake_value_type.PathVar _ -> *) (* Omake_value_type.PathVar info *) (* | PathField (path, _, _) -> *) (* squash_path_info path info *) (* * When finding a value, also construct the path to * the value. *) let venv_find_field_path_exn _venv path obj _pos v = Omake_value_type.PathField (path, obj, v), Lm_symbol.SymbolTable.find obj v let venv_find_field_path venv path obj pos v = try venv_find_field_path_exn venv path obj pos v with Not_found -> let pos = Pos.string_pos "venv_find_field_path" pos in raise (Omake_value_type.OmakeException (pos, UnboundFieldVar (obj, v))) (* * Simple finding. *) let venv_find_field_exn _venv obj _pos v = Lm_symbol.SymbolTable.find obj v let venv_find_field venv obj pos v = try venv_find_field_exn venv obj pos v with Not_found -> let pos = Pos.string_pos "venv_find_field" pos in raise (Omake_value_type.OmakeException (pos, UnboundFieldVar (obj, v))) (* * Super fields come from the class. *) let venv_find_super_field venv pos loc v1 v2 = let table = Omake_value_util.venv_get_class venv.venv_this in try let obj = Lm_symbol.SymbolTable.find table v1 in venv_find_field_exn venv obj pos v2 with Not_found -> let pos = Pos.string_pos "venv_find_super_field" (Pos.loc_pos loc pos) in raise (Omake_value_type.OmakeException (pos, StringVarError ("unbound super var", v2))) (* * Add a field. *) let venv_add_field venv obj _pos v e = venv, Lm_symbol.SymbolTable.add obj v e (* * Hacked versions bypass translation. *) let venv_add_field_internal = Lm_symbol.SymbolTable.add let venv_defined_field_internal = Lm_symbol.SymbolTable.mem let venv_find_field_internal_exn = Lm_symbol.SymbolTable.find let venv_find_field_internal obj pos v = try Lm_symbol.SymbolTable.find obj v with Not_found -> let pos = Pos.string_pos "venv_find_field_internal" pos in raise (Omake_value_type.OmakeException (pos, UnboundFieldVar (obj, v))) let venv_object_fold_internal = Lm_symbol.SymbolTable.fold let venv_object_length = Lm_symbol.SymbolTable.cardinal (* * Test whether a field is defined. *) let venv_defined_field_exn _venv obj v = Lm_symbol.SymbolTable.mem obj v let venv_defined_field venv obj v = try venv_defined_field_exn venv obj v with Not_found -> false (* * Add a class to an object. *) let venv_add_class obj v = let table = Omake_value_util.venv_get_class obj in let table = Lm_symbol.SymbolTable.add table v obj in Lm_symbol.SymbolTable.add obj Omake_value_util.class_sym (ValClass table) (* * Execute a method in an object. * If we are currently in the outermost object, * push the dynamic scope. *) let venv_with_object venv this = { venv with venv_this = this } (* * Define a new object. *) let venv_define_object venv = venv_with_object venv Lm_symbol.SymbolTable.empty (* * Add the class to the current object. *) let venv_instanceof obj s = Lm_symbol.SymbolTable.mem (Omake_value_util.venv_get_class obj) s (* * Include the fields in the given class. * Be careful to merge classnames. *) let venv_include_object_aux obj1 obj2 = let table1 = Omake_value_util.venv_get_class obj1 in let table2 = Omake_value_util.venv_get_class obj2 in let table = Lm_symbol.SymbolTable.fold Lm_symbol.SymbolTable.add table1 table2 in let obj1 = Lm_symbol.SymbolTable.fold Lm_symbol.SymbolTable.add obj1 obj2 in Lm_symbol.SymbolTable.add obj1 Omake_value_util.class_sym (ValClass table) let venv_include_object venv obj2 = let obj = venv_include_object_aux venv.venv_this obj2 in { venv with venv_this = obj } let venv_flatten_object venv obj2 = let obj = venv_include_object_aux venv.venv_dynamic obj2 in { venv with venv_dynamic = obj } (* * Function scoping. *) let venv_empty_env = Lm_symbol.SymbolTable.empty let venv_get_env venv = venv.venv_static let venv_with_env venv env = { venv with venv_static = env } (* * The current object is always in the venv_this field. *) let venv_this venv = venv.venv_this let venv_current_object venv classnames = let obj = venv.venv_this in if classnames = [] then obj else let table = Omake_value_util.venv_get_class obj in let table = List.fold_left (fun table v -> Lm_symbol.SymbolTable.add table v obj) table classnames in Lm_symbol.SymbolTable.add obj Omake_value_util.class_sym (ValClass table) (* * ZZZ: this will go away in 0.9.9. *) let rec filter_objects venv pos v objl = function obj :: rev_objl -> let objl = try venv_find_field_exn venv obj pos v :: objl with Not_found -> objl in filter_objects venv pos v objl rev_objl | [] -> objl let venv_current_objects venv pos v = let { venv_this = this; venv_dynamic = dynamic; venv_static = static; _ } = venv in let v, objl = match v with Omake_ir.VarPrivate (_, v) -> v, [static] | VarThis (_, v) -> v, [static; dynamic; this] | VarVirtual (_, v) -> v, [dynamic] | VarGlobal (_, v) -> v, [static; this; dynamic] in filter_objects venv pos v [] objl (************************************************************************ * Environment. *) (* * Convert a filename to a node. *) let venv_intern venv phony_flag name = let { venv_mount = mount; venv_dir = dir; _ } = venv.venv_inner in let globals = venv_globals venv in let { venv_phonies = phonies; venv_mount_info = mount_info; _ } = globals in Omake_node.create_node_or_phony phonies mount_info mount phony_flag dir name let venv_intern_target venv phony_flag target = match target with Omake_value_type.TargetNode node -> node | TargetString name -> venv_intern venv phony_flag name let venv_intern_cd_1 venv phony_flag dir pname = let mount = venv.venv_inner.venv_mount in let globals = venv_globals venv in let { venv_phonies = phonies; venv_mount_info = mount_info; _ } = globals in Omake_node.create_node_or_phony_1 phonies mount_info mount phony_flag dir pname let venv_intern_cd venv phony_flag dir name = venv_intern_cd_1 venv phony_flag dir (Omake_node.parse_phony_name name) let venv_intern_cd_node_kind venv phony_flag dir pname = let globals = venv_globals venv in let { venv_phonies = phonies; _ } = globals in if Omake_node.node_will_be_phony phonies phony_flag dir pname then Omake_node_sig.NodePhony else Omake_node_sig.NodeNormal let venv_intern_rule_target venv multiple name = let node = match name with Omake_value_type.TargetNode node -> node | TargetString name -> venv_intern venv PhonyOK name in match multiple with | Omake_value_type.RuleScannerSingle | RuleScannerMultiple -> Omake_node.Node.create_escape NodeScanner node | RuleSingle | RuleMultiple -> node let venv_intern_dir venv name = Omake_node.Dir.chdir venv.venv_inner.venv_dir name (* let venv_intern_list venv names = *) (* List.map (venv_intern venv) names *) let node_set_of_list nodes = List.fold_left Omake_node.NodeSet.add Omake_node.NodeSet.empty nodes (* let node_set_add_names venv phony_flag nodes names = *) (* List.fold_left (fun nodes name -> *) (* Omake_node.NodeSet.add nodes (venv_intern venv phony_flag name)) nodes names *) (* let node_set_of_names venv phony_flag names = *) (* node_set_add_names venv phony_flag Omake_node.NodeSet.empty names *) (* * Convert back to a string. *) let venv_dirname venv dir = if Omake_options.opt_absname venv.venv_inner.venv_options then Omake_node.Dir.absname dir else Omake_node.Dir.name venv.venv_inner.venv_dir dir let venv_nodename venv dir = if Omake_options.opt_absname venv.venv_inner.venv_options then Omake_node.Node.absname dir else Omake_node.Node.name venv.venv_inner.venv_dir dir (* * Add a mount point. *) let venv_mount venv options src dst = let inner = venv.venv_inner in let mount = Omake_node.Mount.mount inner.venv_mount options src dst in let inner = { inner with venv_mount = mount } in { venv with venv_inner = inner } (* * A target is wild if it is a string with a wild char. *) let target_is_wild target = match target with Omake_value_type.TargetNode _ -> false | TargetString s -> Lm_wild.is_wild s let string_of_target venv target = match target with |Omake_value_type.TargetString s -> s | Omake_value_type.TargetNode node -> venv_nodename venv node (* * Compile a wild pattern. * It is an error if it isn't wild. *) let compile_wild_pattern _venv pos loc target = match target with | Omake_value_type.TargetString s when Lm_wild.is_wild s -> if Lm_string_util.contains_any s Lm_filename_util.separators then raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, StringStringError ("filename pattern is a path", s))); Lm_wild.compile_in s | _ -> raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, StringTargetError ("patterns must be wildcards", target))) (* * Compile a source. *) let compile_source_core venv s = match s with | Omake_value_type.TargetNode node -> Omake_value_type.SourceNode node | TargetString s -> if Lm_wild.is_wild s then SourceWild (Lm_wild.compile_out s) else SourceNode (venv_intern venv PhonyOK s) let compile_source venv (kind, s) = kind, compile_source_core venv s let compile_implicit3_target pos loc = function |Omake_value_type.TargetString s -> if Lm_string_util.contains_any s Lm_filename_util.separators then raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, StringStringError ("target of a 3-place rule is a path", s))); s | target -> raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, StringTargetError ("target of a 3-place rule is not a simple string", target))) (* * Perform a wild substitution on a source. *) let subst_source_core venv dir subst source = match source with | Omake_value_type.SourceWild wild -> let s = Lm_wild.subst subst wild in venv_intern_cd venv PhonyOK dir s | SourceNode node -> node let subst_source venv dir subst (kind, source) = Omake_node.Node.create_escape kind (subst_source_core venv dir subst source) (* * No wildcard matching. *) let intern_source venv (kind, source) = let source = match source with | Omake_value_type.TargetNode node -> node | TargetString name -> venv_intern venv PhonyOK name in Omake_node.Node.create_escape kind source (************************************************************************ * Rules *) (* * Symbols for directories. *) (* let wild_sym = Lm_symbol.add Lm_wild.wild_string *) let explicit_target_sym = Lm_symbol.add "" (* * Don't save explicit rules. *) let venv_explicit_target venv target = venv_add_var venv Omake_var.explicit_target_var (ValNode target) (* * Save explicit rules. *) let venv_save_explicit_rules venv loc erules = (* Filter out the rules with a different target *) let erules = try match venv_find_var_dynamic_exn venv explicit_target_sym with ValNode target -> let rules = List.fold_left (fun rules erule -> if Omake_node.Node.equal erule.rule_target target then erule :: rules else rules) [] erules in let rules = List.rev rules in let () = if rules = [] then let print_error buf = Format.fprintf buf "@[Computed rule for `%a' produced no useful rules:" Omake_node.pp_print_node target; List.iter (fun erule -> Format.fprintf buf "@ `%a'" Omake_node.pp_print_node erule.rule_target) erules; Format.fprintf buf "@]" in raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, LazyError print_error)) in rules | _ -> erules with Not_found -> erules in venv_save_explicit_rules venv loc erules (* * Add the wild target. *) let venv_add_wild_match venv v = venv_add_var venv Omake_var.wild_var v let command_add_wild venv wild command = match command with Omake_value_type.CommandSection _ -> command | CommandValue(loc, env, s) -> let env = venv_get_env (venv_add_wild_match (venv_with_env venv env) wild) in CommandValue(loc, env, s) (* * This is the standard way to add results of a pattern match. *) let venv_add_match_values venv args = let venv, _ = List.fold_left (fun (venv, i) arg -> let v = Omake_var.create_numeric_var i in let venv = venv_add_var venv v arg in venv, succ i) (venv, 1) args in venv let venv_add_match_args venv args = let venv, _ = List.fold_left (fun (venv, i) arg -> let v = Omake_var.create_numeric_var i in let venv = venv_add_var venv v (ValData arg) in venv, succ i) (venv, 1) args in venv let venv_add_match venv line args = let args = List.map (fun s -> Omake_value_type.ValData s) args in let venv, _ = List.fold_left (fun (venv, i) arg -> let v = Omake_var.create_numeric_var i in let venv = venv_add_var venv v arg in venv, succ i) (venv, 1) args in let venv = venv_add_var venv Omake_var.zero_var (Omake_value_type.ValData line) in let venv = venv_add_var venv Omake_var.star_var (ValArray args) in let venv = venv_add_var venv Omake_var.nf_var (ValInt (List.length args)) in venv (* * Create an environment. *) let create_environ () = let env = Unix.environment () in let len = Array.length env in let rec collect table i = if i = len then table else let s = env.(i) in let j = String.index s '=' in let name = String.sub s 0 j in let name = if Sys.os_type = "Win32" then String.uppercase_ascii name else name in let v = Lm_symbol.add name in let x = String.sub s (j + 1) (String.length s - j - 1) in let table = Lm_symbol.SymbolTable.add table v x in collect table (succ i) in collect Lm_symbol.SymbolTable.empty 0 let create options _dir exec cache = let cwd = Omake_node.Dir.cwd () in let env = create_environ () in let mount_info = { Omake_node_sig.mount_file_exists = Omake_cache.exists cache; mount_file_reset = (fun node -> ignore (Omake_cache.force_stat cache node)); mount_is_dir = Omake_cache.is_dir cache; mount_digest = Omake_cache.stat cache; mount_stat = Omake_cache.stat_unix cache } in let globals = { venv_parent = None; venv_version = 0; venv_mutex = Lm_thread.Mutex.create "venv_globals"; venv_exec = exec; venv_cache = cache; venv_mount_info = mount_info; venv_environments = Lm_handle_table.create (); venv_files = Omake_node.NodeSet.empty; venv_directories = Omake_node.DirTable.empty; venv_excluded_directories = Omake_node.DirSet.empty; venv_phonies = Omake_node.PreNodeSet.empty; venv_explicit_rules = []; venv_explicit_new = []; venv_explicit_targets = Omake_node.NodeTable.empty; venv_ordering_rules = []; venv_orders = Lm_string_set.StringSet.empty; venv_memo_rules = Omake_value_util.ValueTable.empty; venv_pervasives_obj = Lm_symbol.SymbolTable.empty; venv_pervasives_vars = Lm_symbol.SymbolTable.empty; venv_ir_files = Omake_node.NodeTable.empty; venv_object_files = Omake_node.NodeTable.empty; venv_static_values = Omake_node.NodeTable.empty; venv_modified_values = Omake_node.NodeTable.empty; venv_target_dirs = Omake_node.DirTable.empty; venv_target_next_dir = 0; venv_target_is_buildable = TargetMap.empty; venv_target_is_buildable_proper = TargetMap.empty } in let inner = { venv_dir = cwd; venv_environ = env; venv_phony = Omake_node.NodeSet.empty; venv_implicit_deps = []; venv_implicit_rules = []; venv_globals = globals; venv_options = options; venv_mount = Omake_node.Mount.empty; venv_included_files = Omake_node.NodeSet.empty } in let venv = { venv_this = Lm_symbol.SymbolTable.empty; venv_dynamic = Lm_symbol.SymbolTable.empty; venv_static = Lm_symbol.SymbolTable.empty; venv_inner = inner } in let venv = venv_add_phony venv (Lm_location.bogus_loc Omake_state.makeroot_name) [TargetString ".PHONY"] in let venv = venv_add_var venv Omake_var.cwd_var (ValDir cwd) in let venv = venv_add_var venv Omake_var.stdlib_var (ValDir Omake_node.Dir.lib) in let venv = venv_add_var venv Omake_var.stdroot_var (ValNode (venv_intern_cd venv PhonyProhibited Omake_node.Dir.lib "OMakeroot")) in let venv = venv_add_var venv Omake_var.ostype_var (ValString Sys.os_type) in let venv = venv_add_wild_match venv (ValData Lm_wild.wild_string) in let omakepath = try let path = Lm_string_util.split Lm_filename_util.pathsep (Lm_symbol.SymbolTable.find env Omake_symbol.omakepath_sym) in List.map (fun s -> Omake_value_type.ValString s) path with Not_found -> [ValString "."; ValDir Omake_node.Dir.lib] in let omakepath = Omake_value_type.ValArray omakepath in let venv = venv_add_var venv Omake_var.omakepath_var omakepath in let path = try let path = Lm_string_util.split Lm_filename_util.pathsep (Lm_symbol.SymbolTable.find env Omake_symbol.path_sym) in Omake_value_type.ValArray (List.map (fun s -> Omake_value_type.ValData s) path) with Not_found -> Lm_printf.eprintf "*** omake: PATH environment variable is not set!@."; ValArray [] in let venv = venv_add_var venv Omake_var.path_var path in venv (* * Create a fresh environment from the pervasives. * This is used for compiling objects. *) let venv_set_pervasives venv = let globals = venv.venv_inner.venv_globals in let obj = venv.venv_dynamic in let loc = Lm_location.bogus_loc "Pervasives" in let vars = Lm_symbol.SymbolTable.fold (fun vars v _ -> Lm_symbol.SymbolTable.add vars v (Omake_ir.VarVirtual (loc, v))) Lm_symbol.SymbolTable.empty obj in globals.venv_pervasives_obj <- venv.venv_dynamic; globals.venv_pervasives_vars <- vars let venv_get_pervasives venv node = let { venv_inner = inner ; _} = venv in let { venv_environ = env; venv_options = options; venv_globals = globals; _ } = inner in let { venv_pervasives_obj = obj; _ } = globals in let inner = { venv_dir = Omake_node.Node.dir node; venv_environ = env; venv_phony = Omake_node.NodeSet.empty; venv_implicit_deps = []; venv_implicit_rules = []; venv_globals = globals; venv_options = options; venv_mount = Omake_node.Mount.empty; venv_included_files = Omake_node.NodeSet.empty } in { venv_this = Lm_symbol.SymbolTable.empty; venv_dynamic = obj; venv_static = Lm_symbol.SymbolTable.empty; venv_inner = inner } (* * Fork the environment, so that changes really have no effect on the old one. * This is primarly used when a thread wants a private copy of the environment. *) let venv_fork venv = let inner = venv.venv_inner in let globals = inner.venv_globals in let globals = { globals with venv_parent = Some(globals, globals.venv_version); venv_mutex = Lm_thread.Mutex.create "venv_globals"; venv_version = 0; } in let inner = { inner with venv_globals = globals } in { venv with venv_inner = inner } let copy_var src_dynamic dst_dynamic v = try Lm_symbol.SymbolTable.add dst_dynamic v (Lm_symbol.SymbolTable.find src_dynamic v) with Not_found -> Lm_symbol.SymbolTable.remove dst_dynamic v let copy_vars dst_dynamic src_dynamic vars = List.fold_left (copy_var src_dynamic) dst_dynamic vars let copy_var_list = Omake_symbol.[stdin_sym; stdout_sym; stderr_sym] let venv_unfork venv_dst venv_src = let { venv_dynamic = dst_dynamic; venv_inner = dst_inner; _ } = venv_dst in let { venv_dynamic = src_dynamic; venv_inner = src_inner; _ } = venv_src in let inner = { dst_inner with venv_globals = src_inner.venv_globals } in let dst_dynamic = copy_vars dst_dynamic src_dynamic copy_var_list in { venv_dst with venv_dynamic = dst_dynamic; venv_inner = inner } (* * Get the scope of all variables. *) let venv_include_scope venv mode = match mode with IncludePervasives -> venv.venv_inner.venv_globals.venv_pervasives_vars | IncludeAll -> let loc = Lm_location.bogus_loc "venv_include_scope" in let { venv_this = this; venv_dynamic = dynamic; _ } = venv in let vars = Lm_symbol.SymbolTable.mapi (fun v _ -> Omake_ir.VarThis (loc, v)) this in let vars = Lm_symbol.SymbolTable.fold (fun vars v _ -> Lm_symbol.SymbolTable.add vars v (Omake_ir.VarGlobal (loc, v))) vars dynamic in vars (* * Add an included file. *) let venv_is_included_file venv node = Omake_node.NodeSet.mem venv.venv_inner.venv_included_files node let venv_add_included_file venv node = let inner = venv.venv_inner in let inner = { inner with venv_included_files = Omake_node.NodeSet.add inner.venv_included_files node } in { venv with venv_inner = inner } (* * Global state. *) let venv_exec venv = venv.venv_inner.venv_globals.venv_exec let venv_cache venv = venv.venv_inner.venv_globals.venv_cache let venv_add_cache venv cache = let inner = venv.venv_inner in let globals = inner.venv_globals in let globals = { globals with venv_cache = cache } in let inner = { inner with venv_globals = globals } in { venv with venv_inner = inner } (* * Change directories. Update the CWD var, and all a default * rule for all the phonies. *) let venv_chdir_tmp venv dir = { venv with venv_inner = { venv.venv_inner with venv_dir = dir } } let venv_chdir_dir venv loc dir = let inner = venv.venv_inner in let { venv_dir = cwd; venv_phony = phony; _ } = inner in if Omake_node.Dir.equal dir cwd then venv else let venv = venv_add_var venv Omake_var.cwd_var (ValDir dir) in let venv = venv_chdir_tmp venv dir in let globals = venv_globals venv in let phonies = globals.venv_phonies in let phony, phonies = Omake_node.NodeSet.fold (fun (phony, phonies) node -> let node' = Omake_node.Node.create_phony_chdir node dir in let phony = Omake_node.NodeSet.add phony node' in let phonies = Omake_node.PreNodeSet.add phonies (Omake_node.Node.dest node') in venv_add_explicit_dep venv loc node node'; phony, phonies) (Omake_node.NodeSet.empty, phonies) phony in let inner = { inner with venv_dir = dir; venv_phony = phony } in let venv = { venv with venv_inner = inner } in globals.venv_phonies <- phonies; venv let venv_chdir venv loc dir = let dir = Omake_node.Dir.chdir venv.venv_inner.venv_dir dir in venv_chdir_dir venv loc dir (* * The public version does not mess whith the phonies. *) let venv_chdir_tmp venv dir = let cwd = venv.venv_inner.venv_dir in if Omake_node.Dir.equal dir cwd then venv else let venv = venv_add_var venv Omake_var.cwd_var (ValDir dir) in venv_chdir_tmp venv dir (* * Get the dir. *) let venv_dir venv = venv.venv_inner.venv_dir (* * When an OMakefile in a dir is read, save the venv * to be used for targets that do not have nay explicit target rule. *) let venv_add_dir venv = let globals = venv.venv_inner.venv_globals in globals.venv_directories <- Omake_node.DirTable.add globals.venv_directories venv.venv_inner.venv_dir venv let venv_directories venv = let globals = venv.venv_inner.venv_globals in Omake_node.DirSet.fold Omake_node.DirTable.remove globals.venv_directories globals.venv_excluded_directories let venv_add_explicit_dir venv dir = let globals = venv.venv_inner.venv_globals in globals.venv_directories <- Omake_node.DirTable.add globals.venv_directories dir venv; globals.venv_excluded_directories <- Omake_node.DirSet.remove globals.venv_excluded_directories dir let venv_remove_explicit_dir venv dir = let globals = venv.venv_inner.venv_globals in globals.venv_excluded_directories <- Omake_node.DirSet.add globals.venv_excluded_directories dir let venv_find_target_dir_opt venv target = let target_dir = Omake_node.Node.dir target in if Omake_node.Dir.equal venv.venv_inner.venv_dir target_dir then Some venv else try Some (Omake_node.DirTable.find venv.venv_inner.venv_globals.venv_directories target_dir) with Not_found -> None (* * When a file is read, remember it as a configuration file. *) let venv_add_file venv node = let globals = venv.venv_inner.venv_globals in globals.venv_files <- Omake_node.NodeSet.add globals.venv_files node; venv (* * Get all the configuration files. *) let venv_files venv = venv.venv_inner.venv_globals.venv_files (* * Add a null rule. *) let venv_add_implicit_deps venv pos loc multiple patterns locks sources scanners values = let pos = Pos.string_pos "venv_add_implicit_deps" pos in let patterns = List.map (compile_wild_pattern venv pos loc) patterns in let locks = List.map (compile_source venv) locks in let sources = List.map (compile_source venv) sources in let scanners = List.map (compile_source venv) scanners in let nrule = { inrule_loc = loc; inrule_multiple = multiple; inrule_patterns = patterns; inrule_locks = locks; inrule_sources = sources; inrule_scanners = scanners; inrule_values = values } in let venv = { venv with venv_inner = { venv.venv_inner with venv_implicit_deps = nrule :: venv.venv_inner.venv_implicit_deps } } in venv_flush_target_cache venv; venv, [] (* * Add an implicit rule. *) let venv_add_implicit_rule venv loc multiple targets patterns locks sources scanners values body = let irule = { irule_loc = loc; irule_multiple = multiple; irule_targets = targets; irule_patterns = patterns; irule_locks = locks; irule_sources = sources; irule_scanners = scanners; irule_values = values; irule_body = body } in let venv = { venv with venv_inner = { venv.venv_inner with venv_implicit_rules = irule :: venv.venv_inner.venv_implicit_rules } } in venv_flush_target_cache venv; venv, [] (* * Add an 2-place implicit rule. *) let venv_add_implicit2_rule venv pos loc multiple patterns locks sources scanners values body = let pos = Pos.string_pos "venv_add_implicit2_rule" pos in let patterns = List.map (compile_wild_pattern venv pos loc) patterns in let locks = List.map (compile_source venv) locks in let sources = List.map (compile_source venv) sources in let scanners = List.map (compile_source venv) scanners in if Lm_debug.debug debug_implicit then Lm_printf.eprintf "@[venv_add_implicit2_rule:@ @[patterns =%a@]@ @[sources =%a@]@]@." (**) Omake_value_print.pp_print_wild_list patterns Omake_value_print.pp_print_source_list sources; venv_add_implicit_rule venv loc multiple None patterns locks sources scanners values body (* * Add an explicit rule. *) let venv_add_explicit_rules venv pos loc multiple targets locks sources scanners values body = let _pos = Pos.string_pos "venv_add_explicit_rules" pos in let target_args = List.map (venv_intern_rule_target venv multiple) targets in let lock_args = List.map (intern_source venv) locks in let source_args = List.map (intern_source venv) sources in let scanner_args = List.map (intern_source venv) scanners in let effects = node_set_of_list target_args in let locks = node_set_of_list lock_args in let sources = node_set_of_list source_args in let scanners = node_set_of_list scanner_args in let commands = make_command_info venv source_args values body in let add_target target = { rule_loc = loc; rule_env = venv; rule_target = target; rule_effects = effects; rule_locks = locks; rule_sources = sources; rule_scanners = scanners; rule_match = None; rule_multiple = multiple; rule_commands = commands } in let rules = List.map add_target target_args in let names = List.map (fun erule -> erule.rule_target) rules in venv_save_explicit_rules venv loc rules; venv, names (* * Add a 3-place rule (automatically implicit). *) let venv_add_implicit3_rule venv pos loc multiple targets locks patterns sources scanners values body = let pos = Pos.string_pos "venv_add_implicit3_rule" pos in let patterns = List.map (compile_wild_pattern venv pos loc) patterns in let locks = List.map (compile_source venv) locks in let sources = List.map (compile_source venv) sources in let scanners = List.map (compile_source venv) scanners in let targets = List.map (compile_implicit3_target pos loc) targets in let rec check_target target = function pattern :: patterns -> begin match Lm_wild.wild_match pattern target with Some _ -> () | None -> check_target target patterns end | [] -> raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, StringStringError ("bad match", target))) in let () = List.iter (fun target -> check_target target patterns) targets in if Lm_debug.debug debug_implicit then Lm_printf.eprintf "@[venv_add_implicit3_rule:@ @[targets =%a@] @[patterns =%a@]@ @[sources =%a@]@]@." (**) Omake_node.pp_print_string_list targets Omake_value_print.pp_print_wild_list patterns Omake_value_print.pp_print_source_list sources; venv_add_implicit_rule venv loc multiple (Some (Lm_string_set.StringSet.of_list targets)) patterns locks sources scanners values body let rec is_implicit loc = function [] -> false | [target] -> target_is_wild target | target :: targets -> let imp1 = target_is_wild target in let imp2 = is_implicit loc targets in if imp1 <> imp2 then raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, (**) StringError "Rule contains an illegal mixture of implicit (pattern) targets and explicit ones")) else imp1 (* * Figure out what to do based on all the parts. * A 2-place rule is implicit if the targets do not contain a %. 3-place rules are always implicit. *) let venv_add_rule venv pos loc multiple targets patterns locks sources scanners values commands = let pos = Pos.string_pos "venv_add_rule" pos in try match targets, patterns, commands with [], [], _ -> raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, StringError "invalid null rule")) | _, [], [] -> if is_implicit loc targets then venv_add_implicit_deps venv pos loc multiple targets locks sources scanners values else venv_add_explicit_rules venv pos loc multiple targets locks sources scanners values commands | _, [], _ -> if is_implicit loc targets then venv_add_implicit2_rule venv pos loc multiple targets locks sources scanners values commands else venv_add_explicit_rules venv pos loc multiple targets locks sources scanners values commands | _ -> if not (is_implicit loc patterns) then raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, StringError "3-place rule does not contain patterns")) else venv_add_implicit3_rule venv pos loc multiple targets locks patterns sources scanners values commands with Failure err -> raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, StringError err)) (* * Flush the explicit list. *) let venv_explicit_flush venv = let globals = venv.venv_inner.venv_globals in let { venv_explicit_rules = erules; venv_explicit_targets = targets; venv_explicit_new = enew; _ } = globals in if enew <> [] then let targets, erules = List.fold_left (fun (targets, erules) erule -> let erules = erule :: erules in let targets = Omake_node.NodeTable.add targets erule.rule_target erule in targets, erules) (targets, erules) (List.rev enew) in globals.venv_explicit_new <- []; globals.venv_explicit_rules <- erules; globals.venv_explicit_targets <- targets (* * Check if an explicit rule exists. *) let venv_explicit_find venv pos target = venv_explicit_flush venv; try Omake_node.NodeTable.find venv.venv_inner.venv_globals.venv_explicit_targets target with Not_found -> raise (Omake_value_type.OmakeException (pos, StringNodeError ("explicit target not found", target))) let venv_explicit_exists venv target = venv_explicit_flush venv; Omake_node.NodeTable.mem venv.venv_inner.venv_globals.venv_explicit_targets target let multiple_add_error errors target loc1 loc2 = let table = !errors in let table = if Omake_node.NodeMTable.mem table target then table else Omake_node.NodeMTable.add table target loc1 in errors := Omake_node.NodeMTable.add table target loc2 let multiple_print_error errors buf = Format.fprintf buf "@[Multiple ways to build the following targets"; Omake_node.NodeMTable.iter_all (fun target locs -> let locs = List.sort Lm_location.compare locs in Format.fprintf buf "@ @[%a:" Omake_node.pp_print_node target; List.iter (fun loc -> Format.fprintf buf "@ %a" Lm_location.pp_print_location loc) locs; Format.fprintf buf "@]") errors; Format.fprintf buf "@]" let raise_multiple_error errors = let _, loc = Omake_node.NodeMTable.choose errors in raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, LazyError (multiple_print_error errors))) (* * Get the explicit rules. Build a table indexed by target. *) let venv_explicit_rules venv = let errors = ref Omake_node.NodeMTable.empty in let add_target table target erule = Omake_node.NodeTable.filter_add table target (fun entry -> match entry with Some erule' -> (* * For .PHONY targets, multiple is ignored. * Otherwise, multiple must be the same for both targets. *) let multiple = is_multiple_rule erule.rule_multiple in let multiple' = is_multiple_rule erule'.rule_multiple in if Omake_node.Node.is_phony target || (multiple && multiple') || ((not multiple && not multiple') && (commands_are_trivial erule.rule_commands || commands_are_trivial erule'.rule_commands)) then { erule with rule_commands = erule'.rule_commands @ erule.rule_commands } else begin multiple_add_error errors target erule'.rule_loc erule.rule_loc; erule' end | None -> erule) in if not (Omake_node.NodeMTable.is_empty !errors) then raise_multiple_error !errors else let add_deps table target locks sources scanners = Omake_node.NodeTable.filter_add table target (function Some (lock_deps, source_deps, scanner_deps) -> Omake_node.NodeSet.union lock_deps locks, Omake_node.NodeSet.union source_deps sources, Omake_node.NodeSet.union scanner_deps scanners | None -> locks, sources, scanners) in let info = { explicit_targets = Omake_node.NodeTable.empty; explicit_deps = Omake_node.NodeTable.empty; explicit_rules = Omake_node.NodeMTable.empty; explicit_directories = venv_directories venv } in venv_explicit_flush venv; List.fold_left (fun info erule -> let { rule_target = target; rule_locks = locks; rule_sources = sources; rule_scanners = scanners; _ } = erule in let target_table = add_target info.explicit_targets target erule in let dep_table = add_deps info.explicit_deps target locks sources scanners in { info with explicit_targets = target_table; explicit_deps = dep_table; explicit_rules = Omake_node.NodeMTable.add info.explicit_rules target erule }) info (List.rev venv.venv_inner.venv_globals.venv_explicit_rules) (* * Find all the explicit dependencies listed through null * rules. *) let venv_find_implicit_deps_inner venv target = let target_dir = Omake_node.Node.dir target in let target_name = Omake_node.Node.tail target in let is_scanner = match Omake_node.Node.kind target with NodeScanner -> Omake_value_type.RuleScanner | _ -> RuleNormal in List.fold_left (fun (lock_deps, source_deps, scanner_deps, value_deps) nrule -> let { inrule_multiple = multiple; inrule_patterns = patterns; inrule_locks = locks; inrule_sources = sources; inrule_scanners = scanners; inrule_values = values; _ } = nrule in if rule_kind multiple = is_scanner then let rec search patterns = match patterns with pattern :: patterns -> (match Lm_wild.wild_match pattern target_name with Some subst -> let lock_deps = List.fold_left (fun lock_deps source -> let source = subst_source venv target_dir subst source in Omake_node.NodeSet.add lock_deps source) lock_deps locks in let source_deps = List.fold_left (fun names source -> let source = subst_source venv target_dir subst source in Omake_node.NodeSet.add names source) source_deps sources in let scanner_deps = List.fold_left (fun scanner_deps source -> let source = subst_source venv target_dir subst source in Omake_node.NodeSet.add scanner_deps source) scanner_deps scanners in let value_deps = values @ value_deps in lock_deps, source_deps, scanner_deps, value_deps | None -> search patterns) | [] -> lock_deps, source_deps, scanner_deps, value_deps in search patterns else lock_deps, source_deps, scanner_deps, value_deps) (**) (Omake_node.NodeSet.empty, Omake_node.NodeSet.empty, Omake_node.NodeSet.empty, []) venv.venv_inner.venv_implicit_deps let venv_find_implicit_deps venv target = match venv_find_target_dir_opt venv target with Some venv -> venv_find_implicit_deps_inner venv target | None -> Omake_node.NodeSet.empty, Omake_node.NodeSet.empty, Omake_node.NodeSet.empty, [] (* * Find the commands from implicit rules. *) let venv_find_implicit_rules_inner venv target = let target_dir = Omake_node.Node.dir target in let target_name = Omake_node.Node.tail target in let is_scanner = match Omake_node.Node.kind target with NodeScanner -> Omake_value_type.RuleScanner | _ -> RuleNormal in let _ = if Lm_debug.debug debug_implicit then Lm_printf.eprintf "Finding implicit rules for %s@." target_name in let rec patt_search = function pattern :: patterns -> begin match Lm_wild.wild_match pattern target_name with None -> patt_search patterns | (Some _) as subst -> subst end | [] -> None in let rec collect matched = function irule :: irules -> let multiple = irule.irule_multiple in if rule_kind multiple = is_scanner then let subst = if Lm_debug.debug debug_implicit then begin Lm_printf.eprintf "@[venv_find_implicit_rules: considering implicit rule for@ target = %s:@ " target_name; begin match irule.irule_targets with Some targets -> Lm_printf.eprintf "@[3-place targets =%a@]@ " Omake_node.pp_print_string_list (Lm_string_set.StringSet.elements targets) | None -> () end; Lm_printf.eprintf "@[patterns =%a@]@ @[sources =%a@]@]@." (**) Omake_value_print.pp_print_wild_list irule.irule_patterns Omake_value_print.pp_print_source_list irule.irule_sources end; let matches = match irule.irule_targets with None -> true | Some targets -> Lm_string_set.StringSet.mem targets target_name in if matches then patt_search irule.irule_patterns else None in let matched = match subst with Some subst -> let source_args = List.map (subst_source venv target_dir subst) irule.irule_sources in let sources = node_set_of_list source_args in let lock_args = List.map (subst_source venv target_dir subst) irule.irule_locks in let locks = node_set_of_list lock_args in let scanner_args = List.map (subst_source venv target_dir subst) irule.irule_scanners in let scanners = node_set_of_list scanner_args in let core = Lm_wild.core subst in let core_val = Omake_value_type.ValData core in let venv = venv_add_wild_match venv core_val in let commands = List.map (command_add_wild venv core_val) irule.irule_body in let commands = make_command_info venv source_args irule.irule_values commands in let effects = List.fold_left (fun effects pattern -> let effect = Lm_wild.subst_in subst pattern in let effect = venv_intern_rule_target venv multiple (TargetString effect) in Omake_node.NodeSet.add effects effect) Omake_node.NodeSet.empty irule.irule_patterns in let erule = { rule_loc = irule.irule_loc; rule_env = venv; rule_target = target; rule_match = Some core; rule_effects = effects; rule_locks = locks; rule_sources = sources; rule_scanners = scanners; rule_multiple = multiple; rule_commands = commands } in if Lm_debug.debug debug_implicit then Lm_printf.eprintf "@[Added implicit rule for %s:%a@]@." (**) target_name pp_print_command_info_list commands; erule :: matched | None -> matched in collect matched irules else collect matched irules | [] -> List.rev matched in collect [] venv.venv_inner.venv_implicit_rules let venv_find_implicit_rules venv target = match venv_find_target_dir_opt venv target with Some venv -> venv_find_implicit_rules_inner venv target | None -> [] (************************************************************************ * Ordering rules. *) (* * Add an order. *) let venv_add_orders venv loc targets = let globals = venv.venv_inner.venv_globals in let orders = List.fold_left (fun orders target -> let name = match target with | Omake_value_type.TargetNode _ -> raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, StringTargetError (".ORDER should be a name", target))) | TargetString s -> s in Lm_string_set.StringSet.add orders name) globals.venv_orders targets in globals.venv_orders <- orders; venv (* * Check for order. *) let venv_is_order venv name = Lm_string_set.StringSet.mem venv.venv_inner.venv_globals.venv_orders name (* * Add an ordering rule. *) let venv_add_ordering_rule venv pos loc name pattern sources = let pos = Pos.string_pos "venv_add_ordering_deps" pos in let pattern = compile_wild_pattern venv pos loc pattern in let sources = List.map (compile_source_core venv) sources in let orule = { orule_loc = loc; orule_name = name; orule_pattern = pattern; orule_sources = sources } in let globals = venv.venv_inner.venv_globals in globals.venv_ordering_rules <- orule :: globals.venv_ordering_rules; venv (* * Get the ordering dependencies for a name. *) let venv_get_ordering_info venv name = List.fold_left (fun orules orule -> if Lm_symbol.eq orule.orule_name name then orule :: orules else orules) [] venv.venv_inner.venv_globals.venv_ordering_rules (* * Get extra dependencies. *) let venv_get_ordering_deps venv orules deps = let step deps = Omake_node.NodeSet.fold (fun deps dep -> let target_dir = Omake_node.Node.dir dep in let target_str = Omake_node.Node.tail dep in List.fold_left (fun deps orule -> let { orule_pattern = pattern; orule_sources = sources; _ } = orule in match Lm_wild.wild_match pattern target_str with Some subst -> List.fold_left (fun deps source -> let source = subst_source_core venv target_dir subst source in Omake_node.NodeSet.add deps source) deps sources | None -> deps) deps orules) deps deps in let rec fixpoint deps = let deps' = step deps in if Omake_node.NodeSet.cardinal deps' = Omake_node.NodeSet.cardinal deps then deps else fixpoint deps' in fixpoint deps (************************************************************************ * Static rules. *) (* * Each of the commands evaluates to an object. *) let venv_add_memo_rule venv _pos loc _multiple is_static key vars sources values body = let source_args = List.map (intern_source venv) sources in let sources = node_set_of_list source_args in let srule = { srule_loc = loc; srule_static = is_static; srule_env = venv; srule_key = key; srule_deps = sources; srule_vals = values; srule_exp = body } in let globals = venv_globals venv in let venv = List.fold_left (fun venv info -> let _, v = Omake_ir_util.var_of_var_info info in venv_add_var venv info (ValDelayed (ref (Omake_value_type.ValStaticApply (key, v))))) venv vars in globals.venv_memo_rules <- Omake_value_util.ValueTable.add globals.venv_memo_rules key (StaticRule srule); venv (* * Force the evaluation. *) let venv_set_static_info venv key v = let globals = venv_globals venv in globals.venv_memo_rules <- Omake_value_util.ValueTable.add globals.venv_memo_rules key v let venv_find_static_info venv pos key = try Omake_value_util.ValueTable.find venv.venv_inner.venv_globals.venv_memo_rules key with Not_found -> raise (Omake_value_type.OmakeException (pos, StringValueError ("Static section not defined", key))) (************************************************************************ * Return values. *) (* * Export an item from one environment to another. *) let copy_var pos dst src v = try Lm_symbol.SymbolTable.add dst v (Lm_symbol.SymbolTable.find src v) with Not_found -> raise (Omake_value_type.OmakeException (pos, UnboundVar v)) let export_item pos venv_dst venv_src = function | Omake_ir.ExportVar (VarPrivate (_, v)) -> { venv_dst with venv_static = copy_var pos venv_dst.venv_static venv_src.venv_static v } | ExportVar (VarThis (_, v)) -> { venv_dst with venv_this = copy_var pos venv_dst.venv_this venv_src.venv_this v } | ExportVar (VarVirtual (_, v)) -> { venv_dst with venv_dynamic = copy_var pos venv_dst.venv_dynamic venv_src.venv_dynamic v } | ExportVar (VarGlobal (_, v)) -> (* * For now, we don't know which scope to use, so we * copy them all. *) let { venv_dynamic = dynamic_src; venv_static = static_src; venv_this = this_src; _ } = venv_src in let { venv_dynamic = dynamic_dst; venv_static = static_dst; venv_this = this_dst; _ } = venv_dst in let dynamic, found = try Lm_symbol.SymbolTable.add dynamic_dst v (Lm_symbol.SymbolTable.find dynamic_src v), true with Not_found -> dynamic_dst, false in let static, found = try Lm_symbol.SymbolTable.add static_dst v (Lm_symbol.SymbolTable.find static_src v), true with Not_found -> static_dst, found in let this, found = try Lm_symbol.SymbolTable.add this_dst v (Lm_symbol.SymbolTable.find this_src v), true with Not_found -> this_dst, found in if not found then raise (Omake_value_type.OmakeException (pos, UnboundVar v)); { venv_dst with venv_dynamic = dynamic; venv_static = static; venv_this = this } | ExportRules -> (* * Export the implicit rules. *) let inner_src = venv_src.venv_inner in let inner_dst = { venv_dst.venv_inner with venv_implicit_deps = inner_src.venv_implicit_deps; venv_implicit_rules = inner_src.venv_implicit_rules; } in { venv_dst with venv_inner = inner_dst } | ExportPhonies -> (* * Export the phony vars. *) let inner_dst = { venv_dst.venv_inner with venv_phony = venv_src.venv_inner.venv_phony } in { venv_dst with venv_inner = inner_dst } let export_list pos venv_dst venv_src vars = List.fold_left (fun venv_dst v -> export_item pos venv_dst venv_src v) venv_dst vars (* * Exported environment does not include static values. * * We want to preserve pointer equality on venv2 to avoid giving unnecessary * "these files are targeted separately, but appear as effects of a single rule" * warnings. *) let venv_export_venv venv1 venv2 = if venv1.venv_static == venv2.venv_static then venv2 else { venv2 with venv_static = venv1.venv_static } (* * Add the exported result to the current environment. *) let add_exports venv_dst venv_src pos = function |Omake_ir.ExportNone -> venv_dst | ExportAll -> venv_export_venv venv_dst venv_src | ExportList vars -> export_list pos venv_dst venv_src vars (* * venv_orig - environment before the function call. * venv_dst - environment after "entering" the object namespace, before the function call * venv_src - environment after the function call * * # venv_orig is here * A.B.C.f(1) * # venv_dst is venv_orig with this = A.B.C * # venv_src is venv when A.B.C.f returns * * 1. export from venv_src into venv_dst * 2. take venv_orig.venv_this * 3. update along the path A.B.C *) let rec hoist_path venv path obj = match path with | Omake_value_type.PathVar v -> venv_add_var venv v (ValObject obj) | PathField (path, parent_obj, v) -> let obj = Lm_symbol.SymbolTable.add parent_obj v (ValObject obj) in hoist_path venv path obj let hoist_this venv_orig venv_obj path = let venv = { venv_obj with venv_this = venv_orig.venv_this } in hoist_path venv path venv_obj.venv_this let add_path_exports venv_orig venv_dst venv_src pos path ( x : Omake_ir.export) = match x with | ExportNone -> venv_orig | ExportAll -> hoist_this venv_orig (venv_export_venv venv_dst venv_src) path | ExportList vars -> hoist_this venv_orig (export_list pos venv_dst venv_src vars) path (************************************************************************ * Squashing. *) let squash_prim_fun f = f let squash_object obj = obj omake-0.10.3/src/env/omake_ir_ast.ml0000644000175000017500000025066613177364665015722 0ustar gerdgerd include Omake_pos.Make (struct let name = "Omake_ir_ast" end) (************************************************************************ * Variable checking. *) let raise_var_def_error pos info1 info2 = let print_error buf = let loc, _ = Omake_ir_util.var_of_var_info info2 in Format.fprintf buf "@[Variable declaration mismatch:@ variable@ %a@ is already defined as@ %a@ %a@]" (**) Omake_ir_print.pp_print_var_info info1 Omake_ir_print.pp_print_var_info info2 Lm_location.pp_print_location loc in raise (Omake_value_type.OmakeException (pos, LazyError print_error)) let check_vars pos (info1 : Omake_ir.var_info) (info2 : Omake_ir.var_info) : unit = match info1, info2 with VarPrivate (_, v1), VarPrivate (_, v2) -> if not (Lm_symbol.eq v1 v2) then raise_var_def_error pos info1 info2 | VarThis (_, v1), VarThis (_, v2) -> if not (Lm_symbol.eq v1 v2) then raise_var_def_error pos info1 info2 | VarVirtual (_, v1), VarVirtual (_, v2) -> if not (Lm_symbol.eq v1 v2) then raise_var_def_error pos info1 info2 | VarGlobal (_, v1), VarGlobal (_, v2) -> if not (Lm_symbol.eq v1 v2) then raise_var_def_error pos info1 info2 | _ -> () (************************************************************************ * Declaration checking. *) (* * Forced variables. *) module type ForcedVarsSig = sig type t val empty : t val mem : t -> Omake_ir.var -> bool val add_var : t -> Omake_value_type.pos -> Omake_ir.var -> Omake_ir.var_info -> t (* val add_param : t -> Omake_value_type.pos -> Omake_ir.var -> Omake_ir.var_info -> t *) val add_extern : t -> Omake_ir.var -> Omake_ir.var_info -> t val find_var : t -> Omake_ir.var -> Omake_ir.var_info val fold_var : ('a -> Omake_ir.var -> Omake_ir.var_info -> 'a) -> 'a -> t -> 'a val to_vars : t -> Omake_ir.senv end;; module ForcedVars : ForcedVarsSig = struct type forced_info = (* Variable in this file *) ForcedVar of Omake_ir.var_info (* Variable defined outside this file (usually builtin) *) | ForcedExtern of Omake_ir.var_info type t = forced_info Lm_symbol.SymbolTable.t let empty = Lm_symbol.SymbolTable.empty let mem = Lm_symbol.SymbolTable.mem let find_var env v = match Lm_symbol.SymbolTable.find env v with ForcedVar info | ForcedExtern info -> info (* let find_local_var env v = *) (* match Lm_symbol.SymbolTable.find env v with *) (* ForcedVar info -> *) (* info *) (* | ForcedExtern _ -> *) (* raise Not_found *) (* let add_param env _pos v info = *) (* Lm_symbol.SymbolTable.add env v (ForcedVar info) *) let add_var env _pos v info = Lm_symbol.SymbolTable.add env v (ForcedVar info) let add_extern env v info = Lm_symbol.SymbolTable.add env v (ForcedExtern info) let fold_var f x env = Lm_symbol.SymbolTable.fold (fun x v info -> match info with | ForcedExtern _ -> x | ForcedVar info -> f x v info) x env (* * Extract the set of vars so they can be re-used. *) let to_vars env = fold_var Lm_symbol.SymbolTable.add Lm_symbol.SymbolTable.empty env end;; (* * Some values get checked against corresponding definitions. *) module type AllVarsSig = sig type t val empty : t val add : t -> Omake_ir.simple_var_info -> Omake_ir.var_info -> t val find : t -> Omake_ir.simple_var_info -> Omake_ir.var_info (* val iter : (Omake_ir.simple_var_info -> Omake_ir.var_info -> unit) -> t -> unit *) end;; module AllVars : AllVarsSig = struct type t = Omake_ir.var_info Omake_ir_util.SimpleVarTable.t (* Inherit *) let empty = Omake_ir_util.SimpleVarTable.empty let find = Omake_ir_util.SimpleVarTable.find (* let iter = Omake_ir_util.SimpleVarTable.iter *) let add = Omake_ir_util.SimpleVarTable.add end;; (************************************************************************ * Types. *) (* * Environment for parsing AST files. *) type senv_open_file = string -> Omake_value_type.pos -> Lm_location.t -> Omake_node.Node.t * Omake_ir.senv (* * Are we toplevel, or in an object, or a function. *) type context = ContextTop | ContextFunction of Omake_ir.return_id | ContextRule | ContextObject (* * What to export from the current section. *) type export_mode = ExportNoneMode | ExportAllMode of Lm_location.t | ExportListMode of Lm_location.t * Omake_ir.export_item list (* * Context environment. This is strictly scoped, * and not affected by exports. *) type cenv = { (* The forcing mode, if there is one *) cenv_scope : Omake_ir.var_scope option; (* Are we in an object, or a function, or toplevel? *) cenv_context : context; } (* * Scoping environment. * The values here are affected by exports, but otherwise * respect scoping/indentation. *) type senv = { (* Forced, non-private definitions in the current object/file *) senv_object_senv : Omake_ir.senv; (* The variables that we know about *) senv_update_vars : Omake_ir.senv; senv_forced_vars : ForcedVars.t; senv_all_vars : AllVars.t; (* What sections are exporting *) senv_export_mode : export_mode; (* The current environment *) senv_venv : Omake_env.t } (* * "Object" environment. * * This is an environment that is global to each object. * That is, each object gets a fresh environment. *) type oenv = { (* Class names for the current object *) oenv_class_names : Lm_symbol.SymbolSet.t; } (* * "Lazy" environment. * * This environment is for collecting eager expressions * inside a lazy block. *) type genv_lazy = { genv_lazy_mode : bool; genv_lazy_values : (Lm_location.t * Omake_ir.string_exp) Lm_symbol.SymbolTable.t; } (* * Global environment. *) type genv = { (* How to open a file *) genv_open_file : senv_open_file; (* The name of this file *) genv_file : Omake_node.Node.t; (* Index of the next static section *) genv_static_index : int; (* Count up the number of warnings *) genv_warning_count : int; (* Lazy mode *) genv_lazy : genv_lazy } (* * Parsing environment has a set of environments. *) type penv = genv * oenv * senv * cenv (* * Static results. We use this to keep track of what is being * exported. * * ValValue: a value, or something besides an export * ValExport: exporting some variables * ValNotReached: the statement is never executed * (because it is after a return statement) *) type value = ValValue | ValNotReached | ValExport of Omake_ir.var_info Lm_symbol.SymbolTable.t (* * Parameters. *) type param_info = RequiredParam | NormalParam | OptionalParam of Omake_ir.string_exp (************************************************************************ * Name info. *) let empty_name_info = { Omake_ir.name_static = false; name_scope = None; name_curry = false } let is_nonempty_name_info info = info <> empty_name_info (* * Empty object environment. *) let oenv_empty = { oenv_class_names = Lm_symbol.SymbolSet.empty; } (* * Empty lazy environment. *) let lazy_empty = { genv_lazy_mode = false; genv_lazy_values = Lm_symbol.SymbolTable.empty } let lazy_env = { genv_lazy_mode = true; genv_lazy_values = Lm_symbol.SymbolTable.empty } (************************************************************************ * Utilities. *) (* * Add a warning. *) (* let genv_add_warning genv = *) (* { genv with genv_warning_count = succ genv.genv_warning_count } *) let genv_warn_error genv senv = let { genv_file = file; genv_warning_count = count; _ } = genv in if count <> 0 && Omake_options.opt_warn_error (Omake_env.venv_options senv.senv_venv) then let filename = Omake_node.Node.absname file in let loc = Lm_location.bogus_loc filename in raise (Omake_value_type.OmakeException (loc_exp_pos loc, StringIntError ("warnings treated as errors", count))) (************************************************************************ * Utilities. *) (* * In a nested object, all currently protected vars become private. *) (* let nested_object_vars vars = *) (* Lm_symbol.SymbolTable.map (function *) (* Omake_ir.VarThis (loc, v) -> *) (* Omake_ir.VarPrivate (loc, v) *) (* | x -> x) vars *) (* * Collect the cases in a conditional. *) let rec collect_if cases el = match el with Omake_ast.CommandExp (v, e, body, _) :: el when Lm_symbol.eq v Omake_symbol.elseif_sym -> collect_if ((e, body) :: cases) el | Omake_ast.CommandExp (v, _e, body, loc) :: el when Lm_symbol.eq v Omake_symbol.else_sym -> let cases = (Omake_ast.StringOtherExp ("true", loc), body) :: cases in List.rev cases, el | _ -> List.rev cases, el let is_true_string s = match s with Omake_ast.StringOtherExp ("true", _) -> true | _ -> false (* * Generic case collection. *) let rec collect_cases cases el = match el with (Omake_ast.CommandExp (v, e, body, _) :: el) when Lm_symbol.SymbolSet.mem Omake_symbol.clauses_set v -> collect_cases ((v, e, body) :: cases) el | (Omake_ast.CatchExp (v1, v2, body, loc) :: el) -> collect_cases ((v1, Omake_ast.StringOtherExp (Lm_symbol.to_string v2, loc), body) :: cases) el | _ -> List.rev cases, el (* * Extract an option. *) let extract_option loc map key = try let x = Lm_symbol.SymbolTable.find map key in let map = Lm_symbol.SymbolTable.remove map key in x, map with Not_found -> Omake_ast.NullExp loc, map let build_bool_exp loc b = Omake_ir.ConstString (loc, if b then "true" else "false") (************************************************************************ * Environments. *) (* * Simple variables. *) let var_scope_of_var_info = function | Omake_ir.VarPrivate _ -> Omake_ir.VarScopePrivate | VarThis _ -> VarScopeThis | VarVirtual _ -> VarScopeVirtual | VarGlobal _ -> VarScopeGlobal (* * What is the actual mode of a variable in a context? *) let cenv_var_scope (cenv : cenv) (info : Omake_ir.name_info) = let scope = match cenv.cenv_context, info.name_scope with | ContextTop, None | ContextFunction _, None | ContextRule, None | _, Some VarScopeVirtual -> Omake_ir.VarScopeVirtual | ContextObject, None | _, Some VarScopeThis -> VarScopeThis | _, Some VarScopePrivate -> VarScopePrivate | _, Some VarScopeGlobal -> VarScopeGlobal in scope (* * Force the scope. *) let cenv_update_scope cenv (info : Omake_ir.name_info) = let scope = match info.name_scope with None -> cenv.cenv_scope | scope -> scope in { info with name_scope = scope; } let cenv_scope cenv = let { cenv_scope = scope; _ } = cenv in { Omake_ir.name_scope = scope; name_curry = false; name_static = false } let cenv_force_scope cenv info = let info = cenv_update_scope cenv info in { cenv with cenv_scope = info.name_scope } let cenv_fun_scope _ id = { (* cenv with *) cenv_scope = None; cenv_context = ContextFunction id } let cenv_rule_scope _ = { (* cenv with *) cenv_scope = None; cenv_context = ContextRule } let cenv_sequence_scope cenv _ = cenv let cenv_return_id cenv pos loc = match cenv.cenv_context with ContextFunction id -> id | ContextTop | ContextRule | ContextObject -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError "misplaced return statement")) let new_return_id loc v = let v = Lm_list_util.last v in loc, Lm_symbol.to_string v (* * Get a new static symbol. *) let genv_new_index genv = let index = genv.genv_static_index in let genv = { genv with genv_static_index = succ index } in genv, index let genv_new_symbol_string name genv = let genv, index = genv_new_index genv in let v = Lm_symbol.make name index in genv, v let genv_new_static_id = genv_new_symbol_string "static" (* * Create the IR, and reset the env. *) let genv_close genv oenv senv e = let vars = ForcedVars.to_vars senv.senv_forced_vars in let ir = { Omake_ir.ir_classnames = Lm_symbol.SymbolSet.to_list oenv.oenv_class_names; ir_vars = vars; ir_exp = e } in genv, oenv, senv, ir (* * Create the environment when we enter a new object from a virtual object. *) let senv_object_body senv _ _ = let senv = { senv with senv_object_senv = Lm_symbol.SymbolTable.empty; senv_update_vars = Lm_symbol.SymbolTable.empty } in let cenv = { (* cenv with *) cenv_scope = Some VarScopeThis; cenv_context = ContextObject } in senv, cenv let senv_static_body = senv_object_body (************************************************************************ * Variable exporting. *) (* * Add all the vars to the parent environment. * Add only those vars we don't already know about. *) let senv_add_export_all pos senv1 forced_vars2 = let pos = string_pos "senv_add_export_all" pos in let { senv_object_senv = object_senv1; senv_update_vars = update_vars1; senv_forced_vars = forced_vars1; senv_all_vars = all_vars1; _ } = senv1 in (* Don't export the private forced vars *) let object_senv, update_vars, forced_vars, all_vars = Lm_symbol.SymbolTable.fold (fun (object_senv, update_vars, forced_vars, all_vars) v info2 -> try let info1 = ForcedVars.find_var forced_vars v in check_vars pos info2 info1; object_senv, update_vars, forced_vars, all_vars with Not_found -> match info2 with VarPrivate _ | VarThis _ | VarVirtual _ | VarGlobal _ -> let object_senv = Lm_symbol.SymbolTable.add object_senv v info2 in let update_vars = Lm_symbol.SymbolTable.add update_vars v info2 in let forced_vars = ForcedVars.add_var forced_vars pos v info2 in let all_vars = AllVars.add all_vars (var_scope_of_var_info info2, v) info2 in object_senv, update_vars, forced_vars, all_vars) (**) (object_senv1, update_vars1, forced_vars1, all_vars1) forced_vars2 in { senv1 with senv_object_senv = object_senv; senv_update_vars = update_vars; senv_forced_vars = forced_vars; senv_all_vars = all_vars } (* * Merge the exports from several cases. * Export all the vars, but issue warnings if the exports exist in * some, but not the others. *) let var_union _ _ _ = raise (Invalid_argument "Omake_ir_ast.senv_merge_forced_vars: internal error") let rec senv_merge_forced_vars pos export1 exports errors = let pos = string_pos "senv_merge_forced_vars" pos in match exports with export2 :: exports -> (* Check that all exports from export1 match up in export2 *) let export2, errors = Lm_symbol.SymbolTable.fold (fun (export2, errors) v info1 -> try let info2 = Lm_symbol.SymbolTable.find export2 v in check_vars pos info1 info2; Lm_symbol.SymbolTable.remove export2 v, errors with Not_found -> export2, Lm_symbol.SymbolTable.add errors v info1) (export2, errors) export1 in (* All remaining variables in export2 are errors *) let errors = Lm_symbol.SymbolTable.union var_union errors export2 in let export1 = Lm_symbol.SymbolTable.union var_union export1 export2 in senv_merge_forced_vars pos export1 exports errors | [] -> export1, errors (* * Print the error messages for any variables that are not * already defined. *) let warned_solution = ref false let senv_warn_merge_errors _genv senv loc errors = let forced_vars = senv.senv_forced_vars in let errors = Lm_symbol.SymbolTable.fold (fun errors v info -> match info with |Omake_ir.VarPrivate _ -> errors | _ -> if ForcedVars.mem forced_vars v then errors else info :: errors) [] errors in if errors <> [] && Omake_options.opt_warn_declare (Omake_env.venv_options senv.senv_venv) then begin Lm_printf.eprintf "@[%a" Lm_location.pp_print_location loc; if not !warned_solution then begin Lm_printf.eprintf "@ The following variables are exported in some cases, but not others."; Lm_printf.eprintf "@ @[Declare or define these variables if you want to avoid this warning."; warned_solution := true end else Lm_printf.eprintf "@ @[The following variables are exported in some cases, but not others."; List.iter (fun info -> Lm_printf.eprintf "@ %a" Omake_ir_print.pp_print_var_info info) errors; Lm_printf.eprintf "@]@]@." end (* * Merge the exports from the cases. * At least one of the cases is an export. * If they are not all exports, then check that the variables * being exported are already declared. *) let senv_merge_exports genv senv1 _cenv pos loc results is_complete = let pos = string_pos "senv_merge_exports" pos in let is_complete, exports = List.fold_left (fun (is_complete, exports) result -> match result with ValValue | ValNotReached -> false, exports | ValExport forced_vars -> is_complete, forced_vars :: exports) (is_complete, []) results in let export1, exports = if is_complete then match exports with export1 :: exports -> export1, exports | [] -> raise (Invalid_argument "senv_merge_exports: empty exports") else Lm_symbol.SymbolTable.empty, exports in let exports, errors = senv_merge_forced_vars pos export1 exports Lm_symbol.SymbolTable.empty in let () = senv_warn_merge_errors genv senv1 loc errors in let senv = senv_add_export_all pos senv1 exports in senv, ValValue (* * Merge the exports only if the results contain an export. *) let all_results_are_not_reached results = List.for_all (fun result -> result = ValNotReached) results let all_results_are_values_or_not_reached results = List.for_all (fun result -> match result with ValValue | ValNotReached -> true | ValExport _ -> false) results let senv_merge_results genv senv1 cenv pos loc results is_complete = let pos = string_pos "senv_merge_results" pos in if is_complete && all_results_are_not_reached results then senv1, ValNotReached else if all_results_are_values_or_not_reached results then senv1, ValValue else senv_merge_exports genv senv1 cenv pos loc results is_complete (* * Merge the exports from an inner section. *) let senv_export_section senv pos result = let pos = string_pos "senv_export_section" pos in match result with ValExport exports -> senv_add_export_all pos senv exports, ValValue | ValValue | ValNotReached -> senv, result (* * Warn if a statement is not reached. *) (* let senv_warn_not_reached genv e result = *) (* match result with *) (* ValNotReached -> *) (* let loc = Omake_ast_util.loc_of_exp e in *) (* Lm_printf.eprintf "@[*** omake warning: %a@ statement not reached@]@." Lm_location.pp_print_location loc; *) (* genv_add_warning genv *) (* | ValValue *) (* | ValExport _ -> *) (* genv *) (* * Get the export vars. *) let senv_export_all_vars senv = ForcedVars.fold_var (fun forced_vars v info -> match info with | VarPrivate _ | VarThis _ | VarVirtual _ | VarGlobal _ -> Lm_symbol.SymbolTable.add forced_vars v info) Lm_symbol.SymbolTable.empty senv.senv_forced_vars let senv_export_var_list items = List.fold_left (fun vars item -> match item with |Omake_ir.ExportRules | ExportPhonies -> vars | ExportVar info -> let _, v = Omake_ir_util.var_of_var_info info in Lm_symbol.SymbolTable.add vars v info) Lm_symbol.SymbolTable.empty items (* let senv_export_value senv info = *) (* match info with *) (* Omake_ir.ExportNone -> *) (* Lm_symbol.SymbolTable.empty *) (* | Omake_ir.ExportAll -> *) (* senv_export_all_vars senv *) (* | Omake_ir.ExportList items -> *) (* senv_export_var_list items *) (* * Items from the export mode. *) let items_of_export_mode = function ExportNoneMode | ExportAllMode _ -> [] | ExportListMode (_, items) -> items (* * Compute the exports in the current environment. *) let senv_add_exports senv result = match result, senv.senv_export_mode with ValNotReached, _ | _, ExportNoneMode -> Omake_ir.ExportNone, ValValue | _, ExportAllMode _ -> Omake_ir.ExportAll, ValExport (senv_export_all_vars senv) | _, ExportListMode (_, items) -> Omake_ir.ExportList items, ValExport (senv_export_var_list items) (************************************************************************ * Variables. *) (* * Create a variable that refers to the Pervasives module. *) let create_pervasives_var loc v = Omake_ir.VarVirtual (loc, v) (* * Create a variable for the given scope. * If we are not in an object, then this is actually a file variable. *) let create_var _genv _ _ _ loc scope v = match scope with | Omake_ir.VarScopePrivate -> Omake_ir.VarPrivate (loc, v) | VarScopeThis -> VarThis (loc, v) | VarScopeVirtual -> VarVirtual (loc, v) | VarScopeGlobal -> VarGlobal (loc, v) (* * Strip the leading qualifiers. *) let parse_declaration _senv pos loc vl = (* Check scoping *) let make_forced_scope info scope2 = match info.Omake_ir.name_scope with Some scope1 -> let print_error buf = Format.fprintf buf "multiple declaration modes: %a and %a" (**) Omake_ir_print.pp_print_var_scope scope1 Omake_ir_print.pp_print_var_scope scope2 in raise (Omake_value_type.OmakeException (loc_pos loc pos, LazyError print_error)) | None -> { info with name_scope = Some scope2 } in (* Read all the qualifiers *) let rec parse info vl = match vl with | [] -> Omake_ir.NameEmpty info | scope_var :: vl -> if Lm_symbol.eq scope_var Omake_symbol.private_sym then parse (make_forced_scope info VarScopePrivate) vl else if Lm_symbol.eq scope_var Omake_symbol.this_sym || Lm_symbol.eq scope_var Omake_symbol.protected_sym then parse (make_forced_scope info VarScopeThis) vl else if Lm_symbol.eq scope_var Omake_symbol.public_sym || Lm_symbol.eq scope_var Omake_symbol.global_sym then parse (make_forced_scope info VarScopeVirtual) vl else if Lm_symbol.eq scope_var Omake_symbol.static_sym then parse { info with name_static = true } vl else if Lm_symbol.eq scope_var Omake_symbol.curry_sym then parse { info with name_curry = true } vl (* ZZZ: Ignore the const modifier in 0.9.8 *) else if Lm_symbol.eq scope_var Omake_symbol.const_sym then parse info vl else NameMethod (info, scope_var, vl) in parse empty_name_info vl (************************************************************************ * Scoping. *) (* * Builtin-vars. *) let builtin_vars = Lm_symbol.SymbolSet.of_list Omake_symbol.[star_sym; gt_sym; at_sym; plus_sym; hat_sym; lt_sym; amp_sym; nf_sym] (* * Get the scope for a variable. * Numeric symbols are global by default. *) let senv_find_var _ oenv senv cenv _pos loc v = if Lm_symbol.is_numeric_symbol v || Lm_symbol.SymbolSet.mem builtin_vars v then oenv, create_pervasives_var loc v else try let info = ForcedVars.find_var senv.senv_forced_vars v in oenv, info with Not_found -> let info = match cenv.cenv_context with ContextTop | ContextRule | ContextFunction _ -> Omake_ir.VarGlobal (loc, v) | ContextObject -> VarThis (loc, v) in oenv, info (* * A path expression. *) let senv_find_scoped_var genv oenv senv cenv pos loc (info : Omake_ir.name_info) v = match info.Omake_ir.name_scope with Some scope -> let info = create_var genv oenv senv cenv loc scope v in oenv, info | None -> senv_find_var genv oenv senv cenv pos loc v let senv_find_method_var genv oenv senv cenv pos loc vl = match parse_declaration senv pos loc vl with NameEmpty _ -> raise (Omake_value_type.OmakeException (pos, StringError "empty method name")) | NameMethod (info, v, vl) -> let curry = info.name_curry in let oenv, info = senv_find_scoped_var genv oenv senv cenv pos loc info v in oenv, curry, info, vl let senv_find_method_nocurry_var genv oenv senv cenv pos loc vl = let oenv, curry, info, vl = senv_find_method_var genv oenv senv cenv pos loc vl in if curry then raise (Omake_value_type.OmakeException (pos, StringError "curry qualifier not allowed")); oenv, info, vl (************************************************************************ * Variable definitions. *) (* * Open a file and include all the symbols. *) let senv_open_file genv senv pos loc filename = let node, vars = genv.genv_open_file filename pos loc in let vars = Lm_symbol.SymbolTable.fold (fun forced_vars v info -> ForcedVars.add_var forced_vars pos v info) senv.senv_forced_vars vars in { senv with senv_forced_vars = vars }, node (* ZZZ: in 0.9.8.x: * If the scope is specified explicitly, * do not add it as a definition to senv. * * This should be uncommented in 0.9.9. *) (* let senv_define_var_info_bogus senv _ _ scope v info = *) (* let { senv_object_senv = object_vars; *) (* senv_update_vars = update_vars; *) (* senv_forced_vars = forced_vars; *) (* senv_all_vars = all_vars; *) (* _ *) (* } = senv *) (* in *) (* (\* They appear in the object only if not private *\) *) (* let object_vars = *) (* match info with *) (* |Omake_ir.VarPrivate _ -> *) (* object_vars *) (* | _ -> *) (* Lm_symbol.SymbolTable.add object_vars v info *) (* in *) (* let update_vars = Lm_symbol.SymbolTable.add update_vars v info in *) (* let all_vars = AllVars.add all_vars (scope, v) info in *) (* { senv with senv_object_senv = object_vars; *) (* senv_update_vars = update_vars; *) (* senv_forced_vars = forced_vars; *) (* senv_all_vars = all_vars *) (* } *) (* * Low-level variable definition. *) let senv_define_var_info senv pos _ scope v info = let { senv_object_senv = object_vars; senv_update_vars = update_vars; senv_forced_vars = forced_vars; senv_all_vars = all_vars; _ } = senv in (* They appear in the object only if not private *) let object_vars = match info with Omake_ir.VarPrivate _ -> object_vars | _ -> Lm_symbol.SymbolTable.add object_vars v info in let forced_vars = ForcedVars.add_var forced_vars pos v info in let update_vars = Lm_symbol.SymbolTable.add update_vars v info in let all_vars = AllVars.add all_vars (scope, v) info in { senv with senv_object_senv = object_vars; senv_update_vars = update_vars; senv_forced_vars = forced_vars; senv_all_vars = all_vars } let senv_define_var scope genv oenv senv cenv pos loc v = let info = create_var genv oenv senv cenv loc scope v in let senv = senv_define_var_info senv pos loc scope v info in senv, info (* * Parameter sorting. *) let check_duplicate_keyword pos keywords v = if Lm_symbol.SymbolTable.mem keywords v then raise (Omake_value_type.OmakeException (pos, StringVarError ("duplicate keyword parameter", v))) let senv_add_params genv oenv senv cenv pos params = let senv, keywords, params = List.fold_left (fun (senv, keywords, params) (v, info, loc) -> let senv, v_info = senv_define_var VarScopeVirtual genv oenv senv cenv pos loc v in match info with NormalParam -> senv, keywords, v_info :: params | RequiredParam -> check_duplicate_keyword pos keywords v; senv, Lm_symbol.SymbolTable.add keywords v (v_info, None), params | OptionalParam s -> check_duplicate_keyword pos keywords v; senv, Lm_symbol.SymbolTable.add keywords v (v_info, Some s), params) (senv, Lm_symbol.SymbolTable.empty, []) params in let keywords = Lm_symbol.SymbolTable.fold (fun keywords v (v_info, x) -> (v, v_info, x) :: keywords) [] keywords in let keywords = List.rev keywords in let params = List.rev params in senv, keywords, params let senv_add_var_aux genv oenv senv cenv pos loc name_info v = if is_nonempty_name_info name_info then let scope = cenv_var_scope cenv name_info in let info = try let info = AllVars.find senv.senv_all_vars (scope, v) in (* ZZZ: check_var_info pos info name_info; *) info with Not_found -> create_var genv oenv senv cenv loc scope v in let senv = senv_define_var_info senv pos loc scope v info in genv, oenv, senv, info else (* ZZZ: in 0.9.8.x: * If the current scope is forced, add the variable in that mode. * Otherwise, if the variable is already defined, use that. * Otherwise, force the variable in global mode. * In all cases, add to senv. * * This should be valid until var3, where the VarScopeGlobal becomes a link var *) let senv, info = match cenv.cenv_scope with Some scope -> senv_define_var scope genv oenv senv cenv pos loc v | None -> try senv, ForcedVars.find_var senv.senv_forced_vars v with Not_found -> senv_define_var VarScopeGlobal genv oenv senv cenv pos loc v in genv, oenv, senv, info (* let senv_add_var genv oenv senv cenv pos loc v = *) (* senv_add_var_aux genv oenv senv cenv pos loc (cenv_scope cenv) v *) let senv_add_scoped_var genv oenv senv cenv pos loc info v = senv_add_var_aux genv oenv senv cenv pos loc (cenv_update_scope cenv info) v let senv_add_method_def_var genv oenv senv cenv pos loc vl = match parse_declaration senv pos loc vl with NameEmpty _ -> raise (Omake_value_type.OmakeException (pos, StringError "empty method name")) | NameMethod (info, v, vl) -> let curry = info.name_curry in let genv, oenv, senv, info = senv_add_scoped_var genv oenv senv cenv pos loc info v in genv, oenv, senv, curry, info, vl let senv_add_method_var genv oenv senv cenv pos loc kind vl = match kind with |Omake_ir.VarDefNormal -> senv_add_method_def_var genv oenv senv cenv pos loc vl | VarDefAppend -> (* ZZZ: we _should_ preserve the scope of the variable. * However, 0.9.8 chooses the forced mode over the * previous mode. *) let oenv, curry, info, vl = senv_find_method_var genv oenv senv cenv pos loc vl in genv, oenv, senv, curry, info, vl let senv_add_method_nocurry_var genv oenv senv cenv pos loc kind vl = let genv, oenv, senv, curry, info, vl = senv_add_method_var genv oenv senv cenv pos loc kind vl in if curry then raise (Omake_value_type.OmakeException (pos, StringError "curry qualifier not allowed")); genv, oenv, senv, info, vl (************************************************************************ * Declarations. *) (* * This is slightly different. If the mode is not specified, then: * top-level variables are public * object variables are protected * function variables are private *) let senv_declare_static_var genv oenv senv cenv pos loc v = let pos = string_pos "senv_declare_static_var" pos in let scope = cenv_var_scope cenv (cenv_scope cenv) in senv_define_var scope genv oenv senv cenv pos loc v let senv_declare_normal_var genv oenv senv cenv pos loc info v = let scope = cenv_var_scope cenv (cenv_update_scope cenv info) in senv_define_var scope genv oenv senv cenv pos loc v (************************************************************************ * Lazy mode. * * Strategy handling. When we enter a lazy mode, we collect any eager parts * in the oenv. *) (* GS. Remember that we can have lazy and eager evaluation ranges in nested applications, e.g. $`(lazy... $,(back to eager $(`lazy again))) We keep track whether we are in a lazy range (in genv-genv_lazy_mode). The idea is now a transformation where the eager parts are pulled out of the lazy ranges, and are evaluated upfront. lazy_push_strategy: called for determining what to do, and for establishing lazy state if a new lazy range is found. The returned genv is for the arguments of the application. lazy_pop_strategy: actually does the transformation. *) type lazy_state = NormalState | EagerState | NestedState | LazyState of genv_lazy let lazy_push_strategy genv strategy = match strategy with Omake_ast.NormalApply | Omake_ast.CommandApply -> genv, NormalState | Omake_ast.EagerApply -> let state = if genv.genv_lazy.genv_lazy_mode then EagerState else NormalState in genv, state | Omake_ast.LazyApply -> if genv.genv_lazy.genv_lazy_mode then genv, NestedState else (* Push a new lazy state when not already lazy *) let state = LazyState genv.genv_lazy in let genv = { genv with genv_lazy = lazy_env } in genv, state let lazy_pop_strategy genv state loc e = match state with NormalState -> genv, e | EagerState -> (* Expression was eager *) (* GS: eager inside some lazy range *) let i = genv.genv_static_index in let v = Lm_symbol.make "eager.x" i in let lenv = genv.genv_lazy in let lenv = { lenv with genv_lazy_values = Lm_symbol.SymbolTable.add lenv.genv_lazy_values v (loc, e) } in let genv = { genv with genv_static_index = i + 1; genv_lazy = lenv } in let e = Omake_ir.ApplyString (loc, VarPrivate (loc, v), [], []) in genv, e | NestedState -> (* Expression was lazy, but nested *) (* GS: i.e. lazy inside iazy range *) genv, LazyString (loc, e) | LazyState lenv_old -> (* GS: lazy in an eager range *) (* Expression was lazy, so pre-evaluate all the eager parts *) let e = Omake_ir.LazyString (loc, e) in let e = Lm_symbol.SymbolTable.fold (fun e1 v (loc, e2) -> let v = Omake_ir.VarPrivate (loc, v) in Omake_ir.LetVarString (loc, v, e2, e1)) e genv.genv_lazy.genv_lazy_values in let genv = { genv with genv_lazy = lenv_old } in genv, e (************************************************************************ * Conversion *) (* * Literal string. *) let build_literal_string e = (* GS: note that this eats quotes! *) let buf = Buffer.create 32 in let rec collect_exp e = match e with Omake_ast.NullExp _ -> () | Omake_ast.StringOpExp (s, _) | Omake_ast.StringIdExp (s, _) | Omake_ast.StringIntExp (s, _) | Omake_ast.StringFloatExp (s, _) | Omake_ast.StringWhiteExp (s, _) | Omake_ast.StringOtherExp (s, _) | Omake_ast.StringKeywordExp (s, _) -> Buffer.add_string buf s | Omake_ast.QuoteExp (el, _) | Omake_ast.QuoteStringExp (_, el, _) | Omake_ast.SequenceExp (el, _) -> collect_exp_list el | Omake_ast.IntExp (_, loc) | Omake_ast.FloatExp (_, loc) | Omake_ast.ArrayExp (_, loc) | Omake_ast.ApplyExp (_, _, _, loc) | Omake_ast.SuperApplyExp (_, _, _, _, loc) | Omake_ast.MethodApplyExp (_, _, _, loc) | Omake_ast.BodyExp (_, loc) | Omake_ast.KeyExp (_, _, loc) | Omake_ast.CommandExp (_, _, _, loc) | Omake_ast.VarDefExp (_, _, _, _, loc) | Omake_ast.VarDefBodyExp (_, _, _, _, loc) | Omake_ast.KeyDefExp (_, _, _, _, loc) | Omake_ast.KeyDefBodyExp (_, _, _, _, loc) | Omake_ast.ObjectDefExp (_, _, _, loc) | Omake_ast.FunDefExp (_, _, _, loc) | Omake_ast.RuleExp (_, _, _, _, _, loc) | Omake_ast.ShellExp (_, loc) | Omake_ast.CatchExp (_, _, _, loc) | Omake_ast.ClassExp (_, loc) -> raise (Omake_value_type.OmakeException (loc_exp_pos loc, SyntaxError "misplaced expression")) and collect_exp_list el = List.iter collect_exp el in collect_exp e; Buffer.contents buf let build_literal_argv e pos = let s = build_literal_string e in try Lm_string_util.parse_args s with Failure _ | Invalid_argument _ -> raise (Omake_value_type.OmakeException (pos, StringStringError ("syntax error", s))) let build_literal_string_opt e = try Some (build_literal_string e) with Omake_value_type.OmakeException _ -> None (* let literal_string_equal e s = *) (* try build_literal_string e = s with *) (* Omake_value_type.OmakeException _ -> *) (* false *) let build_literal_argv_list el = List.map build_literal_string el (* let is_empty_string e = *) (* try build_literal_string e = "" with *) (* Omake_value_type.OmakeException _ -> *) (* false *) (* Some is_static - it's a memo | None - it's not *) let get_memo_target e = try match build_literal_string e with ".STATIC" -> Some true | ".MEMO" -> Some false | _ -> None with Omake_value_type.OmakeException _ -> None (* * Conversion. *) let rec build_string genv oenv senv cenv e pos = let pos = string_pos "build_string" pos in match e with Omake_ast.NullExp loc -> genv, oenv, Omake_ir.NoneString loc | Omake_ast.IntExp (i, loc) -> genv, oenv, IntString (loc, i) | Omake_ast.FloatExp (x, loc) -> genv, oenv, FloatString (loc, x) | Omake_ast.StringOpExp (s, loc) | Omake_ast.StringIdExp (s, loc) | Omake_ast.StringIntExp (s, loc) | Omake_ast.StringFloatExp (s, loc) | Omake_ast.StringOtherExp (s, loc) | Omake_ast.StringKeywordExp (s, loc) -> genv, oenv, ConstString (loc, s) | Omake_ast.StringWhiteExp (s, loc) -> genv, oenv, WhiteString (loc, s) | Omake_ast.QuoteExp (el, loc) -> build_quote_string genv oenv senv cenv el pos loc | Omake_ast.QuoteStringExp (c, el, loc) -> build_quote_string_string genv oenv senv cenv c el pos loc | Omake_ast.SequenceExp ([e], _) -> build_string genv oenv senv cenv e pos | Omake_ast.SequenceExp (el, loc) -> build_sequence_string genv oenv senv cenv el pos loc | Omake_ast.ArrayExp (e, loc) -> build_array_string genv oenv senv cenv e pos loc | Omake_ast.ApplyExp (strategy, v, args, loc) -> build_apply_string genv oenv senv cenv strategy v args pos loc | Omake_ast.SuperApplyExp (strategy, super, v, args, loc) -> build_super_apply_string genv oenv senv cenv strategy super v args pos loc | Omake_ast.MethodApplyExp (strategy, vl, args, loc) -> build_method_apply_string genv oenv senv cenv strategy vl args pos loc | Omake_ast.BodyExp (el, loc) -> build_body_string genv oenv senv cenv el pos loc | Omake_ast.KeyExp (strategy, v, loc) -> build_key_apply_string genv oenv senv cenv strategy v pos loc | Omake_ast.CommandExp (_, _, _, loc) | Omake_ast.VarDefExp (_, _, _, _, loc) | Omake_ast.VarDefBodyExp (_, _, _, _, loc) | Omake_ast.KeyDefExp (_, _, _, _, loc) | Omake_ast.KeyDefBodyExp (_, _, _, _, loc) | Omake_ast.ObjectDefExp (_, _, _, loc) | Omake_ast.FunDefExp (_, _, _, loc) | Omake_ast.RuleExp (_, _, _, _, _, loc) | Omake_ast.ShellExp (_, loc) | Omake_ast.CatchExp (_, _, _, loc) | Omake_ast.ClassExp (_, loc) -> raise (Omake_value_type.OmakeException (loc_pos loc pos, SyntaxError "misplaced expression")) and build_string_list genv oenv senv cenv el pos = let pos = string_pos "build_string_list" pos in let genv, oenv, el = List.fold_left (fun (genv, oenv, el) e -> let genv, oenv, e = build_string genv oenv senv cenv e pos in genv, oenv, e :: el) (genv, oenv, []) el in genv, oenv, List.rev el (* and build_string_opt genv oenv senv cenv sl pos = *) (* let pos = string_pos "build_string_opt" pos in *) (* match sl with *) (* Some s -> *) (* Some (build_string genv oenv senv cenv s pos) *) (* | None -> *) (* None *) (* * Parameter lists. *) and build_params genv oenv senv cenv params pos loc = let pos = string_pos "build_params" pos in let genv, oenv, params = List.fold_left (fun (genv, oenv, params) param -> let genv, oenv, param = match param with Omake_ast.RequiredParam (v, _) -> genv, oenv, (v, RequiredParam, loc) | Omake_ast.NormalParam (v, loc) -> genv, oenv, (v, NormalParam, loc) | Omake_ast.OptionalParam (v, e, loc) -> let genv, oenv, s = build_string genv oenv senv cenv e (loc_pos loc pos) in genv, oenv, (v, OptionalParam s, loc) in genv, oenv, param :: params) (genv, oenv, []) params in let params = List.rev params in let senv, keywords, params = senv_add_params genv oenv senv cenv pos params in genv, oenv, senv, keywords, params (* * When building a sequence, try to collapse adjacent constant strings. *) and build_sequence_string genv oenv senv cenv el pos loc = let pos = string_pos "build_sequence_string" pos in let genv, oenv, args = build_sequence_string_aux genv oenv senv cenv el pos loc in genv, oenv, SequenceString (loc, args) and build_quote_string genv oenv senv cenv el pos loc = let pos = string_pos "build_quote_string" pos in let genv, oenv, args = build_sequence_string_aux genv oenv senv cenv el pos loc in genv, oenv, QuoteString (loc, args) and build_quote_string_string genv oenv senv cenv c el pos loc = let pos = string_pos "build_quote_string_string" pos in let genv, oenv, args = build_sequence_string_aux genv oenv senv cenv el pos loc in genv, oenv, QuoteStringString (loc, c, args) and build_sequence_string_aux genv oenv senv cenv el pos _ = let pos = string_pos "build_sequence_string_aux" pos in let buf = Buffer.create 32 in (* Flush the buffer *) let flush_buffer buf_opt args = match buf_opt with Some loc -> let args = Omake_ir.ConstString (loc, Buffer.contents buf) :: args in Buffer.clear buf; args | None -> args in (* Add a constant string to the buffer *) let add_string buf_opt s loc = Buffer.add_string buf s; match buf_opt with Some loc' -> let loc = Lm_location.union_loc loc' loc in Some loc | None -> Some loc in (* Collect all the strings in the sequence *) let rec collect genv oenv buf_opt args el = match el with [] -> let args = flush_buffer buf_opt args in genv, oenv, List.rev args | e :: el -> let genv, oenv, e = build_string genv oenv senv cenv e pos in match e with NoneString _ -> collect genv oenv buf_opt args el | ConstString (loc, s) -> let buf_opt = add_string buf_opt s loc in collect genv oenv buf_opt args el | IntString _ | FloatString _ | WhiteString _ | FunString _ | KeyApplyString _ | ApplyString _ | SuperApplyString _ | MethodApplyString _ | SequenceString _ | ObjectString _ | BodyString _ | ArrayString _ | ArrayOfString _ | QuoteString _ | QuoteStringString _ | ExpString _ | CasesString _ | VarString _ | ThisString _ | LazyString _ | LetVarString _ -> let args = flush_buffer buf_opt args in let args = e :: args in collect genv oenv None args el in collect genv oenv None [] el (* * Compatibility with old binding forms. *) and foreach_warning loc = Lm_printf.eprintf "@[%a:@ Warning: old-style foreach expression.@ \ This expression should use a => binding.@]@." (**) Lm_location.pp_print_location loc and fun_warning loc = Lm_printf.eprintf "@[%a:@ Warning: old-style fun expression.@ \ This expression should use a => binding.@]@." (**) Lm_location.pp_print_location loc and build_compat_args _ _ _ _ v args _ loc = match args with [Omake_ast.ExpArg body; Omake_ast.ExpArg x; Omake_ast.ExpArg e] when Lm_symbol.eq v Omake_symbol.foreach_sym -> (match build_literal_string_opt x with Some x -> foreach_warning loc; [Omake_ast.ArrowArg ([Omake_ast.NormalParam (Lm_symbol.add x, loc)], body); Omake_ast.ExpArg e] | None -> args) | [Omake_ast.ExpArg x; Omake_ast.ExpArg body] when Lm_symbol.eq v Omake_symbol.fun_sym -> (match build_literal_string_opt x with Some x -> fun_warning loc; [Omake_ast.ArrowArg ([Omake_ast.NormalParam (Lm_symbol.add x, loc)], body)] | None -> args) | _ -> args (* * New-style foreach methods have a single argument: the function. * Multi-argument foreach should be converted. *) and build_method_compat_args _ _ _ _ vl args _ loc = if Lm_symbol.eq (Lm_list_util.last vl) Omake_symbol.foreach_sym then (* New-style foreach methods have a single argument *) match args with [Omake_ast.ExpArg body; Omake_ast.ExpArg x] -> (match build_literal_string_opt x with Some x -> foreach_warning loc; [Omake_ast.ArrowArg ([Omake_ast.NormalParam (Lm_symbol.add x, loc)], body)] | None -> args) | [Omake_ast.ExpArg body; Omake_ast.ExpArg x; Omake_ast.ExpArg y] -> (match build_literal_string_opt x, build_literal_string_opt y with Some x, Some y -> foreach_warning loc; [Omake_ast.ArrowArg ([Omake_ast.NormalParam (Lm_symbol.add x, loc); Omake_ast.NormalParam (Lm_symbol.add y, loc)], body)] | _ -> args) | _ -> args else args (* * Applications might have parameters. * If they do, then add a function value to the arguments. *) and build_arg senv cenv pos loc (genv, oenv, args, kargs) arg = match arg with Omake_ast.ExpArg e -> let genv, oenv, s = build_string genv oenv senv cenv e pos in genv, oenv, s :: args, kargs | Omake_ast.KeyArg (v, e) -> let genv, oenv, s = build_string genv oenv senv cenv e pos in genv, oenv, args, (v, s) :: kargs | Omake_ast.ArrowArg (params, e) -> let genv, oenv, senv, keywords, params = build_params genv oenv senv cenv params pos loc in let genv, oenv, e, export = match e with Omake_ast.BodyExp (el, _) -> let genv, oenv, e, export, _ = build_body genv oenv senv cenv el pos loc in genv, oenv, e, export | e -> let genv, oenv, s = build_string genv oenv senv cenv e pos in genv, oenv, [Omake_ir.StringExp (loc, s)], Omake_ir.ExportNone in let e = Omake_ir.FunString (loc, keywords, params, e, export) in genv, oenv, e :: args, kargs and build_arg_list genv oenv senv cenv args pos loc = let pos = string_pos "build_arg_list" pos in let genv, oenv, args, kargs = List.fold_left (build_arg senv cenv pos loc) (genv, oenv, [], []) args in let args = List.rev args in let kargs = List.sort (fun (v1, _) (v2, _) -> Lm_symbol.compare v1 v2) kargs in genv, oenv, args, kargs and build_apply_args genv oenv senv cenv v args pos loc = let pos = string_pos "build_apply_body" pos in let args = build_compat_args genv oenv senv cenv v args pos loc in build_arg_list genv oenv senv cenv args pos loc and build_method_apply_args genv oenv senv cenv vl args pos loc = let pos = string_pos "build_apply_body" pos in let args = build_method_compat_args genv oenv senv cenv vl args pos loc in build_arg_list genv oenv senv cenv args pos loc (* * Build an array of strings. *) and build_array_string genv oenv senv cenv args pos loc = let pos = string_pos "build_array_string" pos in let genv, oenv, args = build_string_list genv oenv senv cenv args pos in genv, oenv, ArrayString (loc, args) (* * Build an application. *) and build_apply_string genv oenv senv cenv strategy v args pos loc = let pos = string_pos "build_apply_string" pos in if Lm_symbol.eq v Omake_symbol.this_sym then begin if args <> [] then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError "illegal arguments")); genv, oenv, ThisString loc end else let genv, lazy_state = lazy_push_strategy genv strategy in let genv, oenv, args, kargs = build_apply_args genv oenv senv cenv v args pos loc in let oenv, v = senv_find_var genv oenv senv cenv pos loc v in let e = Omake_ir.ApplyString (loc, v, args, kargs) in let genv, e = lazy_pop_strategy genv lazy_state loc e in genv, oenv, e (* * Super call. *) and build_super_apply_string genv oenv senv cenv strategy super v args pos loc = let pos = string_pos "build_super_apply_string" pos in let genv, lazy_state = lazy_push_strategy genv strategy in let genv, oenv, args, kargs = build_apply_args genv oenv senv cenv v args pos loc in let e = Omake_ir.SuperApplyString (loc, super, v, args, kargs) in let genv, e = lazy_pop_strategy genv lazy_state loc e in genv, oenv, e (* * Build a method application. *) and build_method_apply_string genv oenv senv cenv strategy vars args pos loc = let pos = string_pos "build_method_apply_string" pos in let genv, lazy_state = lazy_push_strategy genv strategy in let genv, oenv, args, kargs = build_method_apply_args genv oenv senv cenv vars args pos loc in let oenv, v, vl = senv_find_method_nocurry_var genv oenv senv cenv pos loc vars in let e = match vl with [] -> Omake_ir.ApplyString (loc, v, args, kargs) | _ -> MethodApplyString (loc, v, vl, args, kargs) in let genv, e = lazy_pop_strategy genv lazy_state loc e in genv, oenv, e (* * Key application $|xxx| *) and build_key_apply_string genv oenv _ _ strategy v _ loc = let genv, lazy_state = lazy_push_strategy genv strategy in let e = Omake_ir.KeyApplyString (loc, v) in let genv, e = lazy_pop_strategy genv lazy_state loc e in genv, oenv, e (* * Build a body expression. *) and build_body_string genv oenv senv cenv el pos loc = let pos = string_pos "build_body_string" pos in let genv, oenv, body, export, _ = build_body genv oenv senv cenv el pos loc in genv, oenv, BodyString (loc, body, export) (* * Build an expression. *) and build_exp genv oenv senv cenv result e = let pos = string_pos "build_exp" (ast_exp_pos e) in match e with Omake_ast.NullExp loc | Omake_ast.IntExp (_, loc) | Omake_ast.FloatExp (_, loc) | Omake_ast.StringOpExp (_, loc) | Omake_ast.StringIdExp (_, loc) | Omake_ast.StringIntExp (_, loc) | Omake_ast.StringFloatExp (_, loc) | Omake_ast.StringWhiteExp (_, loc) | Omake_ast.StringOtherExp (_, loc) | Omake_ast.StringKeywordExp (_, loc) | Omake_ast.QuoteExp (_, loc) | Omake_ast.QuoteStringExp (_, _, loc) -> genv, oenv, senv, Omake_ir.SequenceExp (loc, []), ValValue | Omake_ast.SequenceExp ([e], _) | Omake_ast.BodyExp ([e], _) -> build_exp genv oenv senv cenv result e | Omake_ast.SequenceExp (el, loc) | Omake_ast.BodyExp (el, loc) | Omake_ast.ArrayExp (el, loc) -> build_sequence_exp genv oenv senv cenv result el pos loc | Omake_ast.ApplyExp (_, v, args, loc) -> build_apply_exp genv oenv senv cenv v args pos loc | Omake_ast.SuperApplyExp (_, super, v, args, loc) -> build_super_apply_exp genv oenv senv cenv super v args pos loc | Omake_ast.MethodApplyExp (_, vl, args, loc) -> build_method_apply_exp genv oenv senv cenv vl args pos loc | Omake_ast.CommandExp (v, arg, commands, loc) -> build_command_exp genv oenv senv cenv v arg commands pos loc | Omake_ast.VarDefExp (v, kind, flag, e, loc) -> build_var_def_exp genv oenv senv cenv v kind flag e pos loc | Omake_ast.VarDefBodyExp (v, kind, flag, [], loc) -> build_var_def_exp genv oenv senv cenv v kind flag (Omake_ast.SequenceExp ([], loc)) pos loc | Omake_ast.VarDefBodyExp (v, kind, flag, el, loc) -> build_var_def_body_exp genv oenv senv cenv v kind flag el pos loc | Omake_ast.KeyExp (_, v, loc) -> genv, oenv, senv, KeyExp (loc, v), ValValue | Omake_ast.KeyDefExp (v, kind, flag, e, loc) -> build_key_def_exp genv oenv senv cenv v kind flag e pos loc | Omake_ast.KeyDefBodyExp (v, kind, flag, el, loc) -> build_key_def_body_exp genv oenv senv cenv v kind flag el pos loc | Omake_ast.ObjectDefExp (v, flag, el, loc) -> build_object_def_exp genv oenv senv cenv v flag el pos loc | Omake_ast.FunDefExp (v, params, e, loc) -> build_fun_def_exp genv oenv senv cenv v params e pos loc | Omake_ast.RuleExp (multiple, target, pattern, source, commands, loc) -> build_rule_exp genv oenv senv cenv multiple target pattern source commands pos loc | Omake_ast.ShellExp (e, loc) -> build_shell_exp genv oenv senv cenv e pos loc | Omake_ast.CatchExp (_, _, _, _) -> raise (Omake_value_type.OmakeException (pos, StringError "misplaced catch clause")) | Omake_ast.ClassExp (names, loc) -> build_class_exp genv oenv senv cenv loc names (* * Add the class names. *) and build_class_exp genv oenv senv _ loc names = let oenv = { (* oenv with *) oenv_class_names = Lm_symbol.SymbolSet.add_list oenv.oenv_class_names names } in genv, oenv, senv, SequenceExp (loc, []), ValValue (* * Sequence exp. Build the expression one at a time. *) and build_sequence genv oenv senv cenv result pos rval el = match el with Omake_ast.CommandExp (v, e, body, loc) :: el when Lm_symbol.eq v Omake_symbol.if_sym -> let cases, el = collect_if [e, body] el in let pos = loc_pos loc pos in let cenv_body = cenv_sequence_scope cenv el in let genv, oenv, senv, e, result = build_if_exp genv oenv senv cenv_body cases pos loc in let genv, oenv, senv, el, result = build_sequence genv oenv senv cenv result pos rval el in genv, oenv, senv, e :: el, result | Omake_ast.CommandExp (v, e, body, loc) :: el when Lm_symbol.eq v Omake_symbol.while_sym -> let cases, el = collect_cases [] el in let pos = loc_pos loc pos in let cenv_body = cenv_sequence_scope cenv el in let genv, oenv, senv, e, result = build_opt_cases_command_exp genv oenv senv cenv_body v e cases body pos loc in let genv, oenv, senv, el, result = build_sequence genv oenv senv cenv result pos rval el in genv, oenv, senv, e :: el, result | Omake_ast.CommandExp (v, e, body, loc) :: el -> let cases, el = collect_cases [] el in let pos = loc_pos loc pos in if Lm_symbol.eq v Omake_symbol.export_sym then let oenv, senv = build_export_command genv oenv senv cenv e cases body pos loc in build_sequence genv oenv senv cenv result pos rval el else let cenv_body = cenv_sequence_scope cenv el in let genv, oenv, senv, e, result = build_cases_command_exp genv oenv senv cenv_body v e cases body pos loc in let genv, oenv, senv, el, result = build_sequence genv oenv senv cenv result pos rval el in genv, oenv, senv, e :: el, result | Omake_ast.ApplyExp (_, v, args, loc) :: el -> let cases, el = collect_cases [] el in let pos = loc_pos loc pos in let genv, oenv, senv, e, result = build_cases_apply_exp genv oenv senv cenv v args cases pos loc in let genv, oenv, senv, el, result = build_sequence genv oenv senv cenv result pos rval el in genv, oenv, senv, e :: el, result (* ZZZ: preserve the old behavior of changing the mode to protected * after a class definition. *) | Omake_ast.ClassExp (names, loc) :: el -> let genv, oenv, senv, e, result = build_class_exp genv oenv senv cenv loc names in let cenv = { cenv with cenv_scope = Some VarScopeThis } in let genv, oenv, senv, el, result = build_sequence genv oenv senv cenv result pos rval el in genv, oenv, senv, e :: el, result | e :: el -> let genv, oenv, senv, e, result = build_exp genv oenv senv cenv result e in let genv, oenv, senv, el, result = build_sequence genv oenv senv cenv result pos rval el in genv, oenv, senv, e :: el, result | [] -> rval genv oenv senv cenv result (* * Normal sequences are always in global mode. *) and build_body genv oenv senv cenv el pos _ = let pos = string_pos "build_body" pos in let genv, oenv, senv, el, result = build_sequence genv oenv senv cenv ValValue pos (fun genv oenv senv _ result -> genv, oenv, senv, [], result) el in let export, result = senv_add_exports senv result in genv, oenv, el, export, result (* * Export the environment. *) and build_export_command genv oenv senv cenv e cases body pos loc = let pos = string_pos "build_export_command" pos in let () = if cases <> [] then raise (Omake_value_type.OmakeException (pos, StringError "illegal cases")); if body <> [] then raise (Omake_value_type.OmakeException (pos, StringError "illegal body")) in (* Merge the export set *) let argv = build_literal_argv e pos in let oenv, mode = match senv.senv_export_mode, argv with _, ["all"] -> Lm_printf.eprintf "@[*** omake WARNING: %a:\ @ @[\"export all\" syntax is deprecated;\ @ use an empty \"export\" instead.@]@]@." pp_print_pos pos; oenv, ExportAllMode loc | _, [] | ExportAllMode _, _ -> oenv, ExportAllMode loc | mode, argv -> let items = items_of_export_mode mode in let oenv, items = List.fold_left (fun (oenv, items) v -> let oenv, item = match v with "rules" -> Lm_printf.eprintf "@[*** omake WARNING: %a:\ @ @[\"export rules\" syntax is deprecated;\ @ use \"export .RULE .PHONY\" instead.@]@]@." pp_print_pos pos; oenv, Omake_ir.ExportRules | ".RULE" -> oenv, Omake_ir.ExportRules | ".PHONY" -> oenv, Omake_ir.ExportPhonies | v -> let v = Lm_symbol.add v in let oenv, info = senv_find_var genv oenv senv cenv pos loc v in oenv, Omake_ir.ExportVar info in oenv, item :: items) (oenv, items) argv in oenv, ExportListMode (loc, List.rev items) in let senv = { senv with senv_export_mode = mode } in oenv, senv (* * In an application, turn the arguments into strings. *) and build_apply_exp genv oenv senv cenv v args pos loc = let pos = string_pos "build_apply_exp" pos in let genv, oenv, args, kargs = build_apply_args genv oenv senv cenv v args pos loc in match args with [arg] when Lm_symbol.eq v Omake_symbol.return_sym -> let id = cenv_return_id cenv pos loc in genv, oenv, senv, ReturnExp (loc, arg, id), ValNotReached | args -> let oenv, info = senv_find_var genv oenv senv cenv pos loc v in genv, oenv, senv, ApplyExp (loc, info, args, kargs), ValValue and build_super_apply_exp genv oenv senv cenv super v args pos loc = let pos = string_pos "build_super_apply_exp" pos in let genv, oenv, args, kargs = build_apply_args genv oenv senv cenv v args pos loc in genv, oenv, senv, SuperApplyExp (loc, super, v, args, kargs), ValValue and build_method_apply_exp genv oenv senv cenv vl args pos loc = let pos = string_pos "build_method_apply_exp" pos in let genv, oenv, args, kargs = build_method_apply_args genv oenv senv cenv vl args pos loc in let oenv, v, vl = senv_find_method_nocurry_var genv oenv senv cenv pos loc vl in let e = match vl with | [] -> Omake_ir.ApplyExp (loc, v, args, kargs) | _ -> MethodApplyExp (loc, v, vl, args, kargs) in genv, oenv, senv, e, ValValue and build_cases_apply_exp genv oenv senv cenv v args cases pos loc = let pos = string_pos "build_cases_apply_exp" pos in let genv, oenv, args, kargs = build_apply_args genv oenv senv cenv v args pos loc in match args, cases with [arg], [] when Lm_symbol.eq v Omake_symbol.return_sym -> let id = cenv_return_id cenv pos loc in genv, oenv, senv, ReturnExp (loc, arg, id), ValNotReached | _, [] -> let oenv, v = senv_find_var genv oenv senv cenv pos loc v in genv, oenv, senv, ApplyExp (loc, v, args, kargs), ValValue | _ -> let oenv, v = senv_find_var genv oenv senv cenv pos loc v in let genv, oenv, cases = List.fold_left (fun (genv, oenv, cases) (v, e, body) -> let genv, oenv, body, export, _ = build_body genv oenv senv cenv body pos loc in let genv, oenv, s = build_string genv oenv senv cenv e pos in let case = v, s, body, export in genv, oenv, case :: cases) (genv, oenv, []) cases in let args = Omake_ir.CasesString (loc, List.rev cases) :: args in genv, oenv, senv, ApplyExp (loc, v, args, kargs), ValValue and build_cases_command_exp genv oenv senv cenv v arg cases commands pos loc = let pos = string_pos "build_cases_command_exp" pos in match cases with [] -> build_command_exp genv oenv senv cenv v arg commands pos loc | _ -> let arg = match commands with [] -> arg | _ -> Omake_ast.BodyExp (commands, loc) in build_cases_apply_exp genv oenv senv cenv v [Omake_ast.ExpArg arg] cases pos loc and build_opt_cases_command_exp genv oenv senv cenv v arg cases commands pos loc = let pos = string_pos "build_opt_cases_command_exp" pos in let cases = if commands = [] then cases else let default = Omake_symbol.default_sym, Omake_ast.NullExp loc, commands in cases @ [default] in build_cases_apply_exp genv oenv senv cenv v [Omake_ast.ExpArg arg] cases pos loc (* * The command line is handled at parse time as well as * at evaluation time. *) and build_set_exp genv oenv senv _ e pos loc = let _pos = string_pos "build_set_exp" pos in let argv = build_literal_argv e pos in let senv = { senv with senv_venv = Omake_env.venv_set_options senv.senv_venv loc pos argv } in let argv = List.map (fun s -> Omake_ir.ConstString (loc, s)) argv in let argv = Omake_ir.ArrayString (loc, argv) in let e = Omake_ir.ApplyExp (loc, Omake_var.omakeflags_var, [argv], []) in genv, oenv, senv, e, ValValue (* * Commands. *) and build_command_exp genv oenv senv cenv v arg commands pos loc = let pos = string_pos "build_command_exp" pos in if Lm_symbol.eq v Omake_symbol.include_sym then build_include_exp genv oenv senv cenv arg commands pos loc else if Lm_symbol.eq v Omake_symbol.if_sym then build_if_exp genv oenv senv cenv [arg, commands] pos loc else if Lm_symbol.eq v Omake_symbol.section_sym then build_section_exp genv oenv senv cenv arg commands pos loc else if Lm_symbol.eq v Omake_symbol.value_sym then build_value_exp genv oenv senv cenv arg commands pos loc else if Lm_symbol.eq v Omake_symbol.declare_sym then build_declare_exp genv oenv senv cenv arg commands pos loc else if commands <> [] then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("illegal body for", v))) else if Lm_symbol.eq v Omake_symbol.return_sym then build_return_exp genv oenv senv cenv arg pos loc else if Lm_symbol.eq v Omake_symbol.open_sym then build_open_exp genv oenv senv cenv arg pos loc else if Lm_symbol.eq v Omake_symbol.autoload_sym then genv, oenv, senv, SequenceExp (loc, []), ValValue else if Lm_symbol.eq v Omake_symbol.set_sym then build_set_exp genv oenv senv cenv arg pos loc else build_apply_exp genv oenv senv cenv v [Omake_ast.ExpArg arg] pos loc (* * Include a file. *) and build_include_exp genv oenv senv cenv e commands pos loc = let pos = string_pos "build_include_exp" pos in let genv, oenv, s = build_string genv oenv senv cenv e pos in let genv, oenv, commands = build_string_list genv oenv senv cenv commands pos in genv, oenv, senv, IncludeExp (loc, s, commands), ValValue (* * Conditionals. *) and build_if_exp genv oenv senv cenv cases pos loc = let pos = string_pos "build_if_exp" pos in let genv, oenv, cases, results, is_complete = List.fold_left (fun (genv, oenv, cases, results, is_complete) (e1, e2) -> let is_complete = is_complete || is_true_string e1 in let genv, oenv, s = build_string genv oenv senv cenv e1 pos in let genv, oenv, e2, export, result = build_body genv oenv senv cenv e2 pos loc in let cases = (s, e2, export) :: cases in let results = result :: results in genv, oenv, cases, results, is_complete) (genv, oenv, [], [], false) cases in let senv, result = senv_merge_results genv senv cenv pos loc results is_complete in genv, oenv, senv, IfExp (loc, List.rev cases), result (* * A normal sequence, not a new scope. *) and build_sequence_exp genv oenv senv cenv result el pos loc = let pos = string_pos "build_sequence_exp" pos in let genv, oenv, senv, el, result = build_sequence genv oenv senv cenv result pos (fun genv oenv senv _ result -> genv, oenv, senv, [], result) el in genv, oenv, senv, SequenceExp (loc, el), result (* * A section is just an "if true" command. *) and build_section_exp genv oenv senv cenv e1 e2 pos loc = let pos = string_pos "build_section_exp" pos in let genv, oenv, s = build_string genv oenv senv cenv e1 pos in let genv, oenv, body, export, result = build_body genv oenv senv cenv e2 pos loc in let senv, result = senv_export_section senv pos result in genv, oenv, senv, SectionExp (loc, s, body, export), result (* * Return a value. *) and build_value_exp genv oenv senv cenv e commands pos loc = let pos = string_pos "build_value_exp" pos in let genv, oenv, s = match e, commands with e, [] -> build_string genv oenv senv cenv e pos | Omake_ast.NullExp _, el -> let genv, oenv, el, export, _ = build_body genv oenv senv cenv el pos loc in genv, oenv, ExpString (loc, el, export) | _, _ :: _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError ("Value can have an argument or a body, but not both"))) in genv, oenv, senv, StringExp (loc, s), ValValue and build_return_exp genv oenv senv cenv e pos loc = let pos = string_pos "build_return_exp" pos in let genv, oenv, s = build_string genv oenv senv cenv e pos in let id = cenv_return_id cenv pos loc in genv, oenv, senv, ReturnExp (loc, s, id), ValNotReached (* * Open the namespace from another file. *) and build_open_exp genv oenv senv _ arg pos loc = let pos = string_pos "build_open_exp" pos in let argv = build_literal_argv arg pos in let senv, nodes = List.fold_left (fun (senv, nodes) filename -> let senv, node = senv_open_file genv senv pos loc filename in let nodes = node :: nodes in senv, nodes) (senv, []) argv in genv, oenv, senv, OpenExp (loc, List.rev nodes), ValValue (* * Declare a variable, but dont worry about its definition. *) and build_declare_exp genv oenv senv cenv arg commands pos loc = let pos = string_pos "build_declare_exp" pos in let argv1 = build_literal_argv arg pos in let argv2 = build_literal_argv_list commands in let argv = argv1 @ argv2 in let genv, oenv, senv = List.fold_left (fun (genv, oenv, senv) name -> let name = List.map Lm_symbol.add (Lm_string_util.split "." name) in match parse_declaration senv pos loc name with NameEmpty _ -> raise (Omake_value_type.OmakeException (pos, StringError "illegal name")) | NameMethod (info, v, []) -> let senv, _ = senv_declare_normal_var genv oenv senv cenv pos loc info v in genv, oenv, senv | NameMethod (_, _, _ :: _) -> raise (Omake_value_type.OmakeException (pos, StringError "name has too many components"))) (genv, oenv, senv) argv in genv, oenv, senv, SequenceExp (loc, []), ValValue (* * The public/protected/private are not really objects. * They are scope definitions. *) and build_object_def_exp genv oenv senv cenv vl flag body pos loc = match parse_declaration senv pos loc vl with NameEmpty { name_static = true; name_scope = None ; _} -> build_static_object_exp genv oenv senv cenv body pos loc | NameEmpty { name_static = true ; _} -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError "static objects cannot be qualified")) | NameEmpty info -> build_scope_exp genv oenv senv cenv info body pos loc | NameMethod ({ name_static = true; _ }, _, _) -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError "static named objects are not allowed")) | NameMethod (info, v, vl) -> build_normal_object_exp genv oenv senv cenv info v vl flag body pos loc (* * Qualified definitions, but not a new scope in the * current environment. *) and build_scope_exp genv oenv senv cenv info el pos loc = let pos = string_pos "build_scope_exp" pos in let cenv = cenv_force_scope cenv info in let genv, oenv, senv, el, _ = build_sequence genv oenv senv cenv ValValue pos (fun genv oenv senv _ result -> genv, oenv, senv, [], result) el in genv, oenv, senv, SequenceExp (loc, el), ValValue (* * A static object is evaluated just once. * * ZZZ: this is pretty different in 0.9.9. *) and build_static_object_exp genv oenv senv cenv el pos loc = let pos = string_pos "build_scope_exp" pos in let genv, id = genv_new_static_id genv in let senv_body, cenv_body = senv_static_body senv cenv (Lm_symbol.new_symbol Omake_symbol.static_sym) in let genv, oenv, senv_body, el, _ = build_sequence genv oenv senv_body cenv_body ValValue pos (fun genv oenv senv _ _ -> genv, oenv, senv, [ReturnObjectExp (loc, [])], ValValue) el in let senv, _ = Lm_symbol.SymbolTable.fold (fun (senv, vars) _ info -> match info with |Omake_ir.VarThis (loc, v) -> let senv, info = senv_declare_static_var genv oenv senv cenv pos loc v in senv, info :: vars | VarPrivate _ | VarVirtual _ | VarGlobal _ -> senv, vars) (senv, []) senv_body.senv_object_senv in let file = genv.genv_file in genv, oenv, senv, StaticExp (loc, file, id, el), ValValue (* * An object is a collection of definitions. *) and build_normal_object_exp genv oenv senv cenv info v vl flag body pos loc = let pos = string_pos "build_normal_object_exp" pos in let genv, oenv, senv, parent_string, info = match flag with Omake_ast.DefineNormal -> let genv, oenv, senv, info = senv_add_scoped_var genv oenv senv cenv pos loc info v in let oenv, parent_var = senv_find_var genv oenv senv cenv pos loc Omake_symbol.object_sym in let parent_string = Omake_ir.ApplyString (loc, parent_var, [], []) in genv, oenv, senv, parent_string, info | Omake_ast.DefineAppend -> let oenv, parent_var = senv_find_scoped_var genv oenv senv cenv pos loc info v in let parent_string = match vl with | [] -> Omake_ir.ApplyString (loc, parent_var, [], []) | _ -> MethodApplyString (loc, parent_var, vl, [], []) in (* ZZZ: We should just use the previous info. * However, in 0.9.8 the current forced mode overrides * any previous definition. *) let genv, oenv, senv, var_info = senv_add_scoped_var genv oenv senv cenv pos loc info v in genv, oenv, senv, parent_string, var_info in (* Compile the body *) let rval genv oenv senv _ _ = let class_names = Lm_symbol.SymbolSet.to_list oenv.oenv_class_names in genv, oenv, senv, Omake_ir.[ReturnObjectExp (loc, class_names)], ValValue in let senv_body, cenv_body = senv_object_body senv cenv v in let oenv_body = oenv_empty in let genv, _, senv_body, body, result = build_sequence genv oenv_body senv_body cenv_body ValValue pos rval body in let export, _ = senv_add_exports senv_body result in (* Add the extends directive to the object body *) let e = Omake_ir.LetObjectExp (loc, info, vl, parent_string, body, export) in genv, oenv, senv, e, ValValue (* * Variable definition. *) and build_var_def_kind flag = match flag with Omake_ast.DefineNormal -> Omake_ir.VarDefNormal | Omake_ast.DefineAppend -> VarDefAppend (* * Variable definitions. *) and build_var_def_exp genv oenv senv cenv v kind flag e pos loc = let pos = string_pos "build_var_def_exp" pos in let genv, oenv, s = build_string genv oenv senv cenv e pos in let s = match kind with Omake_ast.DefineString -> s | Omake_ast.DefineArray -> ArrayOfString (loc, s) in let kind = build_var_def_kind flag in match v with [v] when Lm_symbol.eq v Omake_symbol.this_sym -> genv, oenv, senv, LetThisExp (loc, s), ValValue | _ -> let genv, oenv, senv, v, vl = senv_add_method_nocurry_var genv oenv senv cenv pos loc kind v in genv, oenv, senv, LetVarExp (loc, v, vl, kind, s), ValValue and build_var_def_body_exp genv oenv senv cenv v kind flag body pos loc = let pos = string_pos "build_var_def_body_exp" pos in let genv, oenv, e = match kind with Omake_ast.DefineString -> let genv, oenv, el, export, _ = build_body genv oenv senv cenv body pos loc in genv, oenv, Omake_ir.ExpString (loc, el, export) | Omake_ast.DefineArray -> let genv, oenv, sl = build_string_list genv oenv senv cenv body pos in genv, oenv, ArrayString (loc, sl) in let kind = build_var_def_kind flag in let genv, oenv, senv, v, vl = senv_add_method_nocurry_var genv oenv senv cenv pos loc kind v in genv, oenv, senv, LetVarExp (loc, v, vl, kind, e), ValValue (* * Key definitions (for object properties. *) and build_key_def_exp genv oenv senv cenv v kind flag e pos loc = let pos = string_pos "build_key_def_exp" pos in let genv, oenv, s = build_string genv oenv senv cenv e pos in let s = match kind with Omake_ast.DefineString -> s | Omake_ast.DefineArray -> ArrayOfString (loc, s) in let kind = build_var_def_kind flag in genv, oenv, senv, LetKeyExp (loc, v, kind, s), ValValue and build_key_def_body_exp genv oenv senv cenv v kind flag body pos loc = let pos = string_pos "build_key_def_body_exp" pos in let genv, oenv, e = match kind with Omake_ast.DefineString -> let genv, oenv, el, export, _ = build_body genv oenv senv cenv body pos loc in genv, oenv, Omake_ir.ExpString (loc, el, export) | Omake_ast.DefineArray -> let genv, oenv, sl = build_string_list genv oenv senv cenv body pos in genv, oenv, Omake_ir.ArrayString (loc, sl) in let kind = build_var_def_kind flag in genv, oenv, senv, LetKeyExp (loc, v, kind, e), ValValue (* * Function definition. *) and build_fun_def_exp genv oenv senv cenv v params el pos loc = let pos = string_pos "build_fun_def_exp" pos in let cenv_body = cenv_fun_scope cenv (new_return_id loc v) in let genv, oenv, senv_body, opt_params, params = build_params genv oenv senv cenv_body params pos loc in let genv, oenv, body, export, _ = build_body genv oenv senv_body cenv_body el pos loc in let genv, oenv, senv, curry, v, vl = senv_add_method_def_var genv oenv senv cenv pos loc v in genv, oenv, senv, LetFunExp (loc, v, vl, curry, opt_params, params, body, export), ValValue (* * Special rule expressions. *) and build_options_exp genv oenv senv cenv pos loc sources = let genv, oenv, options = Lm_symbol.SymbolTable.fold (fun (genv, oenv, options) v source -> if Lm_symbol.eq v Omake_symbol.normal_sym then genv, oenv, options else let key = Omake_ir.ConstString (loc, Lm_symbol.to_string v) in let genv, oenv, value = build_string genv oenv senv cenv source pos in genv, oenv, key :: value :: options) (genv, oenv, []) sources in let create_map_sym = match options with [] -> Omake_symbol.empty_map_sym | _ -> Omake_symbol.create_lazy_map_sym in let oenv, create_map_var = senv_find_var genv oenv senv cenv pos loc create_map_sym in let options = Omake_ir.ApplyString (loc, create_map_var, options, []) in genv, oenv, options and build_rule_exp genv oenv senv cenv multiple target pattern sources body pos loc = let pos = string_pos "build_rule_exp" pos in let multiple = build_bool_exp loc multiple in match get_memo_target target with Some is_static -> let is_static = build_bool_exp loc is_static in build_memo_rule_exp genv oenv senv cenv multiple is_static pattern sources body pos loc | None -> build_normal_rule_exp genv oenv senv cenv multiple target pattern sources body pos loc and build_normal_rule_exp genv oenv senv cenv multiple target pattern sources body pos loc = let pos = string_pos "build_normal_rule_exp" pos in (* Get the sources *) let source, sources = extract_option loc sources Omake_symbol.normal_sym in let genv, oenv, source = build_string genv oenv senv cenv source pos in let genv, oenv, options = build_options_exp genv oenv senv cenv pos loc sources in (* Get the body *) let genv, oenv, body = let original_class_names = oenv.oenv_class_names in let oenv = { (* oenv with *) oenv_class_names = Lm_symbol.SymbolSet.empty } in let cenv = cenv_rule_scope cenv in let genv, _, body, export, _ = build_body genv oenv senv cenv body pos loc in let oenv = { (* oenv with *) oenv_class_names = original_class_names } in genv, oenv, Omake_ir.BodyString (loc, body, export) in let genv, oenv, target = build_string genv oenv senv cenv target pos in let genv, oenv, pattern = build_string genv oenv senv cenv pattern pos in let args = [multiple; target; pattern; source; options; body] in (* * XXX: until var3, assume that it is written this.rule let oenv, rule_var = senv_find_var genv oenv senv cenv pos loc rule_sym in let e = ApplyExp (loc, rule_var, args, []) in *) let e = Omake_ir.ApplyExp (loc, VarThis (loc, Omake_symbol.rule_sym), args, []) in genv, oenv, senv, e, ValValue and build_memo_rule_exp genv oenv senv cenv multiple is_static names sources body pos loc = let pos = string_pos "build_memo_rule_exp" pos in (* Extract the special keys *) let source, sources = extract_option loc sources Omake_symbol.normal_sym in let key, sources = extract_option loc sources Omake_symbol.key_sym in let genv, oenv, source = build_string genv oenv senv cenv source pos in let genv, oenv, key = build_string genv oenv senv cenv key pos in let genv, oenv, options = build_options_exp genv oenv senv cenv pos loc sources in (* Build the body object expression *) let senv_body, cenv_body = senv_static_body senv cenv (Lm_symbol.new_symbol Omake_symbol.static_sym) in let genv, oenv, senv_body, el, _ = build_sequence genv oenv senv_body cenv_body ValValue pos (fun genv oenv senv _ _ -> genv, oenv, senv, [ReturnObjectExp (loc, [])], ValValue) body in let body = Omake_ir.ObjectString (loc, el, ExportNone) in (* Add the variables to the outer environment *) let names = build_literal_argv names pos in let senv, vars = if names = [] then (* Export all the object variables *) Lm_symbol.SymbolTable.fold (fun (senv, vars) _ info -> match info with |Omake_ir.VarThis (loc, v) -> let senv, info = senv_declare_static_var genv oenv senv cenv pos loc v in senv, info :: vars | VarPrivate _ | VarVirtual _ | VarGlobal _ -> senv, vars) (senv, []) senv_body.senv_object_senv else (* Export only the ones that are named *) List.fold_left (fun (senv, vars) name -> let v = Lm_symbol.add name in let info = try Lm_symbol.SymbolTable.find senv_body.senv_object_senv v with Not_found -> raise (Omake_value_type.OmakeException (pos, UnboundVar v)) in let v = match info with VarThis (_, v) -> v | VarPrivate _ | VarVirtual _ | VarGlobal _ -> raise (Omake_value_type.OmakeException (pos, UnboundVarInfo info)) in let senv, info = senv_declare_static_var genv oenv senv cenv pos loc v in senv, info :: vars) (senv, []) names in let vars = Omake_ir.ArrayString (loc, List.map (fun v -> Omake_ir.VarString (loc, v)) vars) in (* The name has three parts: (file, index, key) *) let file = Omake_ir.ApplyString (loc, Omake_var.file_var, [], []) in let genv, index = genv_new_index genv in let index = Omake_ir.ConstString (loc, string_of_int index) in let args = [multiple; is_static; file; index; key; vars; source; options; body] in let oenv, rule_var = senv_find_var genv oenv senv cenv pos loc Omake_symbol.memo_rule_sym in let e = Omake_ir.ApplyExp (loc, rule_var, args, []) in genv, oenv, senv, e, ValValue (* * Shell command. *) and build_shell_exp genv oenv senv cenv e pos loc = let pos = string_pos "build_shell_exp" pos in let genv, oenv, s = build_string genv oenv senv cenv e pos in genv, oenv, senv, ShellExp (loc, s), ValValue (* * A ReturnFile expression. * Place the initialization function right before. *) let build_return_file_exp _ _ _ _ loc = Omake_ir.ReturnSaveExp loc (* * Build the IR from the AST program. *) let compile_string (genv, oenv, senv, cenv) e pos = let pos = string_pos "build_string" pos in let genv, oenv, s = build_string genv oenv senv cenv e pos in genv_warn_error genv senv; (genv, oenv, senv, cenv), s let compile_exp (genv, oenv, senv, cenv) e = let genv, oenv, senv, e, _ = build_exp genv oenv senv cenv ValValue e in let genv, oenv, senv, ir = genv_close genv oenv senv e in genv_warn_error genv senv; (genv, oenv, senv, cenv), ir let compile_prog (genv, oenv, senv, cenv) el = let loc = Lm_location.bogus_loc "Omake_ir_ast" in let pos = string_pos "compile_prog" (loc_exp_pos loc) in let genv, oenv, senv, el, _ = build_sequence genv oenv senv cenv ValValue pos (fun genv oenv senv cenv _ -> let e = build_return_file_exp genv oenv senv cenv loc in genv, oenv, senv, [e], ValValue) el in let genv, oenv, senv, ir = genv_close genv oenv senv (SequenceExp (loc, el)) in genv_warn_error genv senv; (genv, oenv, senv, cenv), ir let compile_exp_list (genv, oenv, senv, cenv) el = let loc = Lm_location.bogus_loc "Omake_ir_ast" in let pos = string_pos "compile_exp_list" (loc_exp_pos loc) in let genv, oenv, senv, el, _ = build_sequence genv oenv senv cenv ValValue pos (fun genv oenv senv _ result -> genv, oenv, senv, [], result) el in let genv, oenv, senv, ir = genv_close genv oenv senv (SequenceExp (loc, el)) in genv_warn_error genv senv; (genv, oenv, senv, cenv), ir let build_string (genv, oenv, senv, cenv) e pos = let genv, oenv, e = build_string genv oenv senv cenv e pos in genv_warn_error genv senv; (genv, oenv, senv, cenv), e (* * Create the environment. *) let cenv_empty = { cenv_scope = None; cenv_context = ContextTop; } let senv_create venv = { senv_object_senv = Lm_symbol.SymbolTable.empty; senv_update_vars = Lm_symbol.SymbolTable.empty; senv_forced_vars = ForcedVars.empty; senv_all_vars = AllVars.empty; senv_export_mode = ExportNoneMode; senv_venv = venv } let genv_create open_file node = { genv_open_file = open_file; genv_file = node; genv_static_index = 0; genv_warning_count = 0; genv_lazy = lazy_empty } let penv_create open_file venv node = let cenv = cenv_empty in let senv = senv_create venv in let oenv = oenv_empty in let genv = genv_create open_file node in genv, oenv, senv, cenv let penv_class_names (_, oenv, senv, _) = let class_names = Lm_symbol.SymbolSet.to_list oenv.oenv_class_names in let vars = ForcedVars.to_vars senv.senv_forced_vars in class_names, vars let penv_of_vars open_file venv node vars = let genv, oenv, senv, cenv = penv_create open_file venv node in let vars = Lm_symbol.SymbolTable.add vars Omake_symbol.file_sym Omake_var.file_var in let vars = Lm_symbol.SymbolTable.add vars Omake_symbol.file_id_sym Omake_var.file_id_var in let forced_vars, all_vars = Lm_symbol.SymbolTable.fold (fun (forced_vars, all_vars) v info -> let forced_vars = ForcedVars.add_extern forced_vars v info in let all_vars = AllVars.add all_vars (var_scope_of_var_info info, v) info in forced_vars, all_vars) (senv.senv_forced_vars, senv.senv_all_vars) vars in let senv = { senv with senv_forced_vars = forced_vars; senv_all_vars = all_vars } in genv, oenv, senv, cenv omake-0.10.3/src/env/omake_ast_lex.ml0000644000175000017500000027453313177364666016100 0ustar gerdgerd# 12 "omake_ast_lex.mll" include Omake_pos.Make (struct let name = "Omake_ast_lex" end) let debug_lex = Lm_debug.create_debug (**) { debug_name = "debug-ast-lex"; debug_description = "Print tokens as they are scanned"; debug_value = false } (* * Current mode: * ModeNormal: normal lexing mode * ModeString s: parsing a literal string, dollar sequences are still expanded, * s is the quotation delimiter * ModeSkipString s :parsing a literal string, dollar sequences are still expanded, * s is the quotation delimiter, skip the token if it is a quote that is not s * ModeQuote s: parsing a literal string, dollar sequences are still expanded, * escape sequences are allowed, s is the quotation delimiter. * * GS. The main entry is lex_line (below). Depending on the current mode, * a different lexer function is invoked: * * ModeNormal: calls lex_main * ModeString: calls lex_string, for text in $+dquote (e.g. $"") * ModeSkipString: calls lex_skip_string. This is used after newlines inside * $-dquoted-text for checking whether the matching end * quote is following. Fairly technical. * ModeQuote: calls lex_quote, for text after dquote *) type mode = ModeNormal | ModeSkipString of string | ModeString of string | ModeQuote of string (* * The lexing mode. * ModeInitial: lexbuf is ready to be used * ModeIndent i: initial indentation has been scanned * ModeNormal: normal processing * * GS. LexModeInitial means we are at the beginning of the line. LexModeNormal * means that we've just lexed the left indentation. *) type lexmode = LexModeInitial | LexModeNormal of int (* * Parsing results. *) type parse_item = ParseExp of Omake_ast.exp list | ParseError | ParseEOF (* * This is the info for each indentation level. *) type info = { info_mode : mode; info_indent : int; info_parens : int option } (* * State of the lexer. *) type session = { (* The current location *) current_file : Lm_symbol.t; mutable current_line : int; mutable current_off : int; mutable current_loc : Lm_location.t; (* GS TODO: line/off/loc is now tracked by lexbuf (it wasn't in ancient versions of OCaml). Remove this here, and rely on lexbuf only. *) (* The current input buffer *) mutable current_buffer : string; mutable current_index : int; mutable current_prompt : string; mutable current_fill_ok : bool; mutable current_eof : bool; readline : (string -> string); mutable is_interactive : bool; (* The current lexbuf *) mutable current_lexbuf : Lexing.lexbuf; mutable current_lexmode : lexmode; mutable current_token : Omake_ast_parse.token; (* The current mode *) mutable current_mode : mode; mutable current_parens : int option; mutable current_indent : int; mutable current_stack : info list } (************************************************************************ * Printing. NOTICE: if new tokens are added, please update * the token list in omake_gen_parse.ml!!! *) let pp_print_token buf = function Omake_ast_parse.TokEof _ -> Lm_printf.pp_print_string buf "" | TokEol _ -> Lm_printf.pp_print_string buf "" | TokWhite (s, _) -> Format.fprintf buf "whitespace: \"%s\"" s | TokLeftParen (s, _) -> Format.fprintf buf "left parenthesis: %s" s | TokRightParen (s, _) -> Format.fprintf buf "right parenthesis: %s" s | TokArrow (s, _) -> Format.fprintf buf "arrow: %s" s | TokComma (s, _) -> Format.fprintf buf "comma: %s" s | TokColon (s, _) -> Format.fprintf buf "colon: %s" s | TokDoubleColon (s, _) -> Format.fprintf buf "doublecolon: %s" s | TokNamedColon (s, _) -> Format.fprintf buf "named colon: %s" s | TokDollar (s, strategy, _) -> Format.fprintf buf "dollar: %s%a" s Omake_ast_print.pp_print_strategy strategy | TokEq (s, _) -> Format.fprintf buf "equals: %s" s | TokArray (s, _) -> Format.fprintf buf "array: %s" s | TokDot (s, _) -> Format.fprintf buf "dot: %s" s | TokId (s, _) -> Format.fprintf buf "id: %s" s | TokInt (s, _) -> Format.fprintf buf "int: %s" s | TokFloat (s, _) -> Format.fprintf buf "float: %s" s | TokKey (s, _) -> Format.fprintf buf "key: %s" s | TokKeyword (s, _) -> Format.fprintf buf "keyword: %s" s | TokCatch (s, _) -> Format.fprintf buf "catch: %s" s | TokClass (s, _) -> Format.fprintf buf "class: %s" s | TokVar (_, s, _) -> Format.fprintf buf "var: %s" s | TokOp (s, _) -> Format.fprintf buf "op: %s" s | TokString (s, _) -> Format.fprintf buf "string: \"%s\"" (String.escaped s) | TokBeginQuote (s, _) -> Format.fprintf buf "begin-quote: %s" s | TokEndQuote (s, _) -> Format.fprintf buf "end-quote: %s" s | TokBeginQuoteString (s, _) -> Format.fprintf buf "begin-quote-string: %s" s | TokEndQuoteString (s, _) -> Format.fprintf buf "end-quote-string: %s" s | TokStringQuote (s, _) -> Format.fprintf buf "quote: %s" s | TokVarQuote (_, s, _) -> Format.fprintf buf "key: %s" s (* * Set state. *) let create name readline = let loc = Lm_location.bogus_loc name in { current_file = Lm_symbol.add name; current_line = 1; current_off = 0; current_loc = loc; current_buffer = ""; current_index = 0; current_prompt = ">"; current_fill_ok = true; current_eof = true; readline = readline; is_interactive = false; current_lexbuf = Lexing.from_string ""; current_lexmode = LexModeInitial; current_token = TokEof loc; current_mode = ModeNormal; current_parens = None; current_indent = 0; current_stack = [] } (* let set_current_loc state loc = *) (* state.current_loc <- loc *) let current_location state = state.current_loc (* * Advance a line. *) let set_next_line state lexbuf = let { current_line = line; current_file = file; _ } = state in let line = succ line in state.current_line <- line; state.current_off <- Lexing.lexeme_start lexbuf; state.current_loc <- Lm_location.create_loc file line 0 line 0 (* * Save the state. *) let save_mode state = let { current_mode = mode'; current_parens = parens; current_indent = indent; current_stack = stack; _ } = state in let info = { info_mode = mode'; info_parens = parens; info_indent = indent } in info :: stack (* * Restore the state. *) let restore_mode state stack = match stack with info :: stack -> state.current_mode <- info.info_mode; state.current_parens <- info.info_parens; state.current_indent <- info.info_indent; state.current_stack <- stack | [] -> () (* * Push the new mode. *) let push_mode state mode = let stack = save_mode state in state.current_mode <- mode; state.current_parens <- None; state.current_stack <- stack (* * Pop the mode. *) let pop_mode state = restore_mode state state.current_stack (* * We are moving from a quotation to normal mode. * Start collecting parentheses. *) let push_dollar state mode = push_mode state mode; state.current_parens <- Some 0 (* GS. The reason for counting open parentheses (in current_parens) is that a line feed is interpreted differently while there is an open parenthesis. *) (* * Push a paren. *) let push_paren state = let { current_parens = parens ; _} = state in match parens with Some i -> state.current_parens <- Some (succ i) | None -> () (* * When a paren is popped, if the level becomes zero, * then return to the previous mode. *) let pop_paren state = let { current_parens = parens ; _} = state in match parens with Some i -> let i = pred i in if i = 0 then pop_mode state else state.current_parens <- Some i | None -> () (* * Get the location of the current lexeme. * We assume it is all on one line. *) let lexeme_loc state lexbuf = let { current_line = line; current_off = off; current_file = file; _ } = state in let schar = Lexing.lexeme_start lexbuf - off in let echar = Lexing.lexeme_end lexbuf - off in let loc = Lm_location.create_loc file line schar line echar in state.current_loc <- loc; loc (* GS TODO: use Lexing.lexeme_start_p and Lexing.lexeme_end_p instead *) (* * Raise a syntax error exception. *) let parse_error state = let lexbuf = state.current_lexbuf in let loc = lexeme_loc state lexbuf in let print_error buf = Format.fprintf buf "unexpected token: %a" pp_print_token state.current_token in raise (Omake_value_type.OmakeException (loc_exp_pos loc, LazyError print_error)) let syntax_error state s lexbuf = let loc = lexeme_loc state lexbuf in raise (Omake_value_type.OmakeException (loc_exp_pos loc, SyntaxError s)) (* * Get the string in the lexbuf. *) let lexeme_string state lexbuf = let loc = lexeme_loc state lexbuf in let s = Lexing.lexeme lexbuf in s, loc (* * Remove any trailing dots from the string. *) (* let split_nl_string s = *) (* let len = String.length s in *) (* let rec search i = *) (* if i = len then *) (* s, "" *) (* else *) (* match s.[i] with *) (* '\n' *) (* | '\r' -> *) (* search (succ i) *) (* | _ -> *) (* String.sub s 0 i, String.sub s i (len - i) *) (* in *) (* search 0 *) (* * Process a name. *) let lexeme_name state lexbuf = let id, loc = lexeme_string state lexbuf in match id with "if" | "elseif" | "else" | "switch" | "match" | "select" | "case" | "default" | "section" | "include" | "extends" | "import" | "try" | "when" | "finally" | "raise" | "return" | "export" | "open" | "autoload" | "declare" | "value" | "with" | "as" | "while" | "do" | "set" | "program-syntax" -> Omake_ast_parse.TokKeyword (id, loc) | "catch" -> TokCatch (id, loc) | "class" -> TokClass (id, loc) | _ -> TokId (id, loc) let lexeme_key state lexbuf = let id, loc = lexeme_string state lexbuf in Omake_ast_parse.TokKey (id, loc) (* * Get the escaped char. * GS. e.g. "\X" -> "X" *) let lexeme_esc state lexbuf = let s, loc = lexeme_string state lexbuf in String.make 1 s.[1], loc (* * Single character variable. * GS. $x (not $(...)). Also $`x and $,x. *) let lexeme_var state lexbuf = let s, loc = lexeme_string state lexbuf in let strategy, s = match s.[1] with | '`' -> Omake_ast.LazyApply, String.sub s 2 1 | ',' -> EagerApply, String.sub s 2 1 | _ -> NormalApply, String.sub s 1 1 in Omake_ast_parse.TokVar (strategy, s, loc) (* * Dollar sequence. *) let lexeme_dollar_pipe state lexbuf = let s, loc = lexeme_string state lexbuf in let len = String.length s in let strategy, off = if len >= 2 then match s.[1] with '`' -> Omake_ast.LazyApply, 2 | ',' -> EagerApply, 2 | '|' -> NormalApply, 1 | _ -> syntax_error state ("illegal character: " ^ s) lexbuf else NormalApply, 1 in let s = String.sub s off (String.length s - off) in strategy, s, loc (* GS. Unclear why there are two versions of this function. lexeme_dollar seems to be the usual function, for all of $` $, $$ *) let lexeme_dollar state lexbuf = let s, loc = lexeme_string state lexbuf in let len = String.length s in if len >= 2 then match s.[1] with '`' -> Omake_ast_parse.TokDollar (s, LazyApply, loc) | ',' -> TokDollar (s, EagerApply, loc) | '$' -> TokString ("$", loc) | _ -> syntax_error state ("illegal character: " ^ s) lexbuf else TokDollar (s, NormalApply, loc) (* * Special character. * Keep track of paren nesting. *) let lexeme_char state lexbuf = let s, loc = lexeme_string state lexbuf in match s.[0] with '$' -> Omake_ast_parse.TokDollar (s, NormalApply, loc) | ':' -> TokColon (s, loc) | ',' -> TokComma (s, loc) | '=' -> TokEq (s, loc) | '.' -> TokDot (s, loc) | '%' -> TokVar (NormalApply, s, loc) | '(' -> push_paren state; TokLeftParen (s, loc) | ')' -> pop_paren state; TokRightParen (s, loc) | _ -> TokOp (s, loc) (* * Special string. *) let lexeme_special_string state lexbuf = let s, loc = lexeme_string state lexbuf in match s with "=>" -> Omake_ast_parse.TokArrow (s, loc) | "::" -> TokDoubleColon (s, loc) | "+=" -> TokEq (s, loc) | "[]" -> TokArray (s, loc) | _ -> TokOp (s, loc) (* * Count the indentation in a string of characters. *) let indent_of_string s = let len = String.length s in let rec loop col i = if i = len then col else match s.[i] with '\r' | '\n' -> loop 0 (succ i) | '\t' -> loop ((col + 8) land (lnot 7)) (succ i) | _ -> loop (succ col) (succ i) in loop 0 0 (* * Use lexer positions. *) let lexeme_pos lexbuf = let s = Lexing.lexeme lexbuf in let pos1 = Lexing.lexeme_start_p lexbuf in let pos2 = Lexing.lexeme_end_p lexbuf in let { Lexing.pos_fname = file; Lexing.pos_lnum = line1; Lexing.pos_bol = bol1; Lexing.pos_cnum = cnum1 } = pos1 in let { Lexing.pos_lnum = line2; Lexing.pos_bol = bol2; Lexing.pos_cnum = cnum2; _ } = pos2 in let loc = Lm_location.create_loc (Lm_symbol.add file) line1 (cnum1 - bol1) line2 (cnum2 - bol2) in s, loc # 553 "omake_ast_lex.ml" let __ocaml_lex_tables = { Lexing.lex_base = "\000\000\236\255\118\000\160\000\243\255\001\000\058\000\061\000\ \069\000\069\000\237\000\070\000\098\001\249\255\216\001\087\000\ \253\255\088\000\040\002\120\002\199\002\022\003\135\000\255\255\ \001\000\151\000\098\001\099\001\071\001\102\003\181\003\004\004\ \083\004\182\001\162\004\241\004\077\000\000\005\010\005\020\005\ \119\000\101\000\242\255\103\000\058\000\109\000\069\005\147\005\ \006\006\086\006\120\000\098\000\244\255\245\255\041\000\200\006\ \129\000\137\000\116\000\024\007\241\255\113\000\139\007\208\000\ \237\255\004\000\238\255\252\007\247\255\047\008\253\255\000\008\ \013\008\255\255\005\000\248\255\006\000\249\255\251\255\211\008\ \252\255\211\008\248\255\250\255\007\000\042\009\143\000\141\000\ \014\008\156\009\100\001\249\255\008\000\252\255\218\009\253\255\ \174\000\058\000\150\000\146\000\183\008\252\255\063\000\154\000\ \150\000\186\009\255\255\009\000\175\000\066\000\157\000\154\000\ \201\006\255\255\010\000\085\004\087\004\123\010\247\255\248\255\ \132\004\251\255\011\000\252\255\253\255\165\008\209\006\255\255\ \201\010\027\011\067\001\210\004\243\004\249\255\012\000\250\255\ \254\255\233\007\253\255\254\255\234\007\099\001\255\255"; Lexing.lex_backtrk = "\255\255\255\255\016\000\015\000\255\255\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\255\255\015\000\012\000\ \255\255\002\000\002\000\002\000\002\000\002\000\020\000\255\255\ \000\000\001\000\255\255\000\000\255\255\002\000\002\000\002\000\ \002\000\255\255\002\000\004\000\004\000\255\255\004\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\015\000\005\000\ \005\000\005\000\255\255\255\255\255\255\255\255\009\000\011\000\ \008\000\007\000\255\255\255\255\255\255\013\000\015\000\255\255\ \255\255\018\000\255\255\255\255\255\255\005\000\255\255\001\000\ \001\000\255\255\000\000\255\255\007\000\255\255\255\255\005\000\ \255\255\255\255\255\255\255\255\005\000\004\000\001\000\001\000\ \000\000\000\000\000\000\255\255\006\000\255\255\004\000\255\255\ \000\000\000\000\000\000\000\000\255\255\255\255\002\000\002\000\ \002\000\001\000\255\255\000\000\000\000\000\000\000\000\000\000\ \001\000\255\255\000\000\255\255\000\000\255\255\255\255\255\255\ \007\000\255\255\004\000\255\255\255\255\000\000\000\000\255\255\ \000\000\000\000\255\255\255\255\004\000\255\255\006\000\255\255\ \255\255\255\255\255\255\255\255\000\000\000\000\255\255"; Lexing.lex_default = "\003\000\000\000\255\255\003\000\000\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\000\000\046\000\255\255\ \000\000\255\255\255\255\255\255\255\255\255\255\026\000\000\000\ \255\255\255\255\026\000\026\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\000\000\255\255\255\255\255\255\046\000\255\255\ \046\000\255\255\255\255\255\255\000\000\000\000\255\255\255\255\ \255\255\255\255\255\255\255\255\000\000\255\255\003\000\255\255\ \000\000\255\255\000\000\071\000\000\000\255\255\000\000\071\000\ \255\255\000\000\255\255\000\000\255\255\000\000\000\000\255\255\ \000\000\088\000\000\000\000\000\255\255\255\255\255\255\255\255\ \088\000\088\000\255\255\000\000\255\255\000\000\255\255\000\000\ \255\255\255\255\255\255\255\255\105\000\000\000\255\255\255\255\ \255\255\105\000\000\000\255\255\255\255\255\255\255\255\255\255\ \255\255\000\000\255\255\115\000\115\000\119\000\000\000\000\000\ \131\000\000\000\255\255\000\000\000\000\255\255\255\255\000\000\ \255\255\255\255\255\255\131\000\131\000\000\000\255\255\000\000\ \000\000\140\000\000\000\000\000\140\000\255\255\000\000"; Lexing.lex_trans = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\025\000\023\000\023\000\025\000\024\000\064\000\073\000\ \075\000\083\000\091\000\106\000\113\000\121\000\133\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \025\000\000\000\013\000\022\000\012\000\004\000\006\000\013\000\ \004\000\004\000\004\000\009\000\004\000\004\000\015\000\004\000\ \021\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\020\000\010\000\004\000\008\000\011\000\007\000\014\000\ \018\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\017\000\002\000\016\000\004\000\018\000\ \042\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\061\000\005\000\042\000\014\000\066\000\ \064\000\042\000\042\000\065\000\042\000\045\000\041\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\023\000\037\000\043\000\027\000\044\000\066\000\042\000\ \066\000\066\000\066\000\042\000\050\000\066\000\066\000\066\000\ \025\000\023\000\066\000\025\000\024\000\054\000\003\000\046\000\ \056\000\255\255\255\255\057\000\255\255\255\255\060\000\042\000\ \066\000\086\000\037\000\066\000\087\000\042\000\097\000\025\000\ \098\000\099\000\026\000\102\000\103\000\104\000\109\000\110\000\ \255\255\111\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\000\000\255\255\255\255\ \098\000\110\000\066\000\003\000\046\000\099\000\111\000\000\000\ \000\000\000\000\255\255\255\255\255\255\255\255\255\255\000\000\ \000\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\255\255\255\255\255\255\255\255\003\000\ \001\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\000\000\255\255\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\042\000\ \000\000\000\000\097\000\109\000\003\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \058\000\000\000\058\000\000\000\059\000\000\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \000\000\000\000\000\000\000\000\023\000\023\000\091\000\027\000\ \027\000\092\000\127\000\000\000\000\000\000\000\064\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\000\000\000\000\000\000\057\000\142\000\052\000\255\255\ \053\000\056\000\142\000\000\000\053\000\053\000\055\000\000\000\ \000\000\000\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\000\000\000\000\053\000\127\000\ \255\255\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\000\000\053\000\ \053\000\053\000\055\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\000\000\054\000\000\000\ \053\000\255\255\255\255\000\000\255\255\255\255\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\047\000\255\255\255\255\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\255\255\255\255\255\255\255\255\255\255\000\000\ \047\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\255\255\255\255\255\255\255\255\047\000\ \000\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\000\000\255\255\018\000\048\000\000\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\255\255\255\255\091\000\000\000\000\000\000\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\000\000\000\000\000\000\000\000\018\000\ \000\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\000\000\000\000\018\000\018\000\000\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\040\000\000\000\000\000\000\000\000\000\000\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\000\000\000\000\000\000\000\000\018\000\ \255\255\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\000\000\018\000\028\000\018\000\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000\ \018\000\018\000\018\000\018\000\029\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\000\000\000\000\000\000\000\000\018\000\000\000\ \018\000\018\000\018\000\018\000\029\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\000\000\018\000\028\000\018\000\020\000\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \000\000\000\000\000\000\000\000\000\000\000\000\018\000\018\000\ \018\000\018\000\018\000\029\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\000\000\000\000\000\000\000\000\018\000\000\000\018\000\ \032\000\018\000\018\000\029\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\031\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\030\000\018\000\ \018\000\033\000\000\000\034\000\018\000\000\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \000\000\000\000\000\000\000\000\000\000\000\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\000\000\000\000\000\000\000\000\018\000\000\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\000\000\018\000\000\000\018\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\000\000\ \000\000\000\000\000\000\000\000\000\000\018\000\030\000\030\000\ \030\000\030\000\030\000\030\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \000\000\000\000\000\000\000\000\018\000\000\000\030\000\030\000\ \030\000\030\000\030\000\030\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \000\000\018\000\000\000\018\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\018\000\018\000\000\000\000\000\ \000\000\000\000\000\000\000\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\113\000\ \000\000\113\000\116\000\018\000\116\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\000\000\ \018\000\000\000\018\000\032\000\032\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\000\000\121\000\000\000\ \000\000\132\000\000\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\000\000\000\000\ \000\000\000\000\018\000\000\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\000\000\018\000\ \000\000\018\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\121\000\000\000\000\000\132\000\ \000\000\000\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\121\000\000\000\000\000\ \132\000\018\000\000\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\000\000\000\000\000\000\ \018\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\039\000\000\000\039\000\000\000\000\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\255\255\255\255\ \000\000\255\255\255\255\000\000\000\000\113\000\000\000\113\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\255\255\000\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \255\255\255\255\255\255\255\255\255\255\000\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \047\000\255\255\000\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\000\000\000\000\000\000\ \000\000\000\000\255\255\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\000\000\000\000\ \000\000\000\000\047\000\255\255\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\000\000\255\255\ \255\255\047\000\255\255\255\255\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\255\255\000\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\047\000\255\255\255\255\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \255\255\255\255\255\255\255\255\255\255\255\255\047\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\255\255\255\255\255\255\255\255\047\000\000\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\000\000\255\255\047\000\048\000\000\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \050\000\000\000\000\000\000\000\000\000\000\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\000\000\000\000\000\000\000\000\047\000\000\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\000\000\112\000\113\000\047\000\112\000\114\000\000\000\ \000\000\000\000\126\000\121\000\000\000\126\000\122\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\112\000\000\000\000\000\115\000\000\000\053\000\000\000\ \000\000\126\000\053\000\053\000\131\000\000\000\000\000\000\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\000\000\000\000\053\000\000\000\255\255\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\000\000\053\000\053\000\053\000\ \000\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\000\000\054\000\059\000\053\000\000\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\060\000\000\000\000\000\000\000\000\000\000\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\000\000\000\000\000\000\000\000\059\000\ \000\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\000\000\255\255\255\255\059\000\255\255\ \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\255\255\000\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \000\000\255\255\255\255\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\063\000\255\255\255\255\ \255\255\255\255\000\000\000\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\255\255\255\255\ \255\255\255\255\000\000\000\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\073\000\255\255\ \000\000\074\000\255\255\139\000\255\255\255\255\000\000\000\000\ \139\000\255\255\000\000\000\000\000\000\000\000\000\000\075\000\ \255\255\000\000\076\000\255\255\000\000\000\000\070\000\000\000\ \069\000\000\000\255\255\070\000\255\255\000\000\000\000\255\255\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\077\000\ \255\255\000\000\255\255\000\000\077\000\255\255\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\141\000\255\255\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\080\000\000\000\078\000\000\000\000\000\ \072\000\078\000\078\000\079\000\255\255\000\000\000\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\077\000\255\255\078\000\000\000\000\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\255\255\078\000\078\000\078\000\079\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\000\000\000\000\000\000\078\000\135\000\133\000\ \000\000\000\000\134\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\106\000\000\000\000\000\107\000\135\000\000\000\135\000\ \135\000\135\000\000\000\000\000\135\000\135\000\135\000\000\000\ \000\000\135\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\103\000\000\000\000\000\000\000\083\000\104\000\136\000\ \084\000\000\000\135\000\000\000\000\000\000\000\000\000\000\000\ \000\000\138\000\255\255\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\086\000\000\000\085\000\ \000\000\078\000\087\000\000\000\068\000\078\000\078\000\000\000\ \255\255\135\000\000\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\075\000\255\255\078\000\ \000\000\000\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\090\000\ \078\000\078\000\078\000\102\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\095\000\089\000\ \093\000\078\000\000\000\000\000\093\000\093\000\094\000\000\000\ \000\000\000\000\093\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\000\000\000\000\093\000\000\000\ \000\000\093\000\093\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\093\000\093\000\000\000\093\000\ \093\000\093\000\094\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\093\000\133\000\255\255\000\000\ \093\000\255\255\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\101\000\ \000\000\000\000\000\000\000\000\000\000\000\000\255\255\000\000\ \255\255\000\000\000\000\255\255\255\255\000\000\000\000\255\255\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\082\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\255\255\000\000\000\000\000\000\ \000\000\255\255\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \093\000\000\000\000\000\000\000\093\000\093\000\000\000\000\000\ \000\000\000\000\093\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\000\000\000\000\093\000\000\000\ \089\000\093\000\093\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\093\000\093\000\255\255\093\000\ \093\000\093\000\000\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\093\000\093\000\093\000\093\000\ \093\000\093\000\093\000\093\000\093\000\000\000\000\000\000\000\ \093\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\126\000\121\000\000\000\126\000\ \122\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\126\000\255\255\123\000\120\000\000\000\ \000\000\000\000\123\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\124\000\000\000\000\000\ \000\000\000\000\255\255\128\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\127\000\125\000\ \127\000\000\000\128\000\000\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\128\000\000\000\ \000\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\000\000\000\000\000\000\000\000\000\000\ \000\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\000\000\000\000\000\000\000\000\ \128\000\000\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\000\000\000\000\000\000\128\000\ \128\000\000\000\000\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\130\000\000\000\000\000\ \000\000\000\000\000\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\000\000\000\000\ \000\000\000\000\128\000\118\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\000\000\000\000\ \000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000"; Lexing.lex_check = "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\000\000\000\000\024\000\000\000\000\000\065\000\074\000\ \076\000\084\000\092\000\107\000\114\000\122\000\134\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \000\000\255\255\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \006\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\007\000\000\000\005\000\000\000\002\000\ \002\000\008\000\009\000\002\000\011\000\015\000\017\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\022\000\036\000\041\000\022\000\043\000\002\000\044\000\ \002\000\002\000\002\000\045\000\051\000\002\000\002\000\002\000\ \025\000\025\000\002\000\025\000\025\000\054\000\040\000\050\000\ \056\000\003\000\003\000\057\000\003\000\003\000\058\000\061\000\ \002\000\086\000\036\000\002\000\087\000\017\000\097\000\025\000\ \098\000\099\000\025\000\102\000\103\000\104\000\109\000\110\000\ \003\000\111\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\255\255\003\000\003\000\ \096\000\108\000\002\000\040\000\050\000\096\000\108\000\255\255\ \255\255\255\255\003\000\003\000\003\000\003\000\003\000\255\255\ \255\255\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\063\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\255\255\003\000\010\000\010\000\010\000\ \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ \255\255\255\255\096\000\108\000\063\000\010\000\010\000\010\000\ \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ \010\000\255\255\010\000\255\255\010\000\255\255\010\000\010\000\ \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ \255\255\255\255\255\255\255\255\026\000\027\000\090\000\026\000\ \027\000\090\000\130\000\255\255\255\255\255\255\002\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\255\255\255\255\255\255\012\000\141\000\012\000\022\000\ \012\000\012\000\141\000\255\255\012\000\012\000\012\000\255\255\ \255\255\255\255\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\255\255\255\255\012\000\130\000\ \003\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\012\000\255\255\012\000\ \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\255\255\012\000\255\255\ \012\000\014\000\014\000\255\255\014\000\014\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \014\000\255\255\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\255\255\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \255\255\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\255\255\014\000\018\000\014\000\255\255\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\026\000\027\000\090\000\255\255\255\255\255\255\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\255\255\255\255\255\255\255\255\018\000\ \255\255\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\255\255\255\255\019\000\018\000\255\255\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\255\255\255\255\255\255\255\255\255\255\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\255\255\255\255\255\255\255\255\019\000\ \014\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\255\255\020\000\020\000\019\000\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\255\255\255\255\255\255\255\255\255\255\255\255\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\020\000\255\255\255\255\255\255\255\255\020\000\255\255\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\020\000\255\255\021\000\021\000\020\000\021\000\021\000\ \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ \255\255\255\255\255\255\255\255\255\255\255\255\021\000\021\000\ \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\255\255\255\255\255\255\255\255\021\000\255\255\021\000\ \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\029\000\255\255\029\000\021\000\255\255\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \255\255\255\255\255\255\255\255\255\255\255\255\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\255\255\255\255\255\255\255\255\029\000\255\255\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\255\255\030\000\255\255\029\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\255\255\ \255\255\255\255\255\255\255\255\255\255\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \255\255\255\255\255\255\255\255\030\000\255\255\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \255\255\031\000\255\255\030\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\255\255\255\255\ \255\255\255\255\255\255\255\255\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\115\000\ \255\255\116\000\115\000\031\000\116\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\255\255\ \032\000\255\255\031\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\255\255\120\000\255\255\ \255\255\120\000\255\255\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\255\255\255\255\ \255\255\255\255\032\000\255\255\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\255\255\034\000\ \255\255\032\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\131\000\255\255\255\255\131\000\ \255\255\255\255\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\132\000\255\255\255\255\ \132\000\034\000\255\255\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\255\255\255\255\255\255\ \034\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\037\000\255\255\037\000\255\255\255\255\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\046\000\046\000\ \255\255\046\000\046\000\255\255\255\255\115\000\255\255\116\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\046\000\255\255\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\120\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\255\255\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \047\000\046\000\255\255\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\255\255\255\255\255\255\ \255\255\255\255\131\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\255\255\255\255\ \255\255\255\255\047\000\132\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\255\255\048\000\ \048\000\047\000\048\000\048\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\048\000\255\255\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\046\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\255\255\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\255\255\048\000\049\000\048\000\255\255\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\255\255\255\255\255\255\255\255\255\255\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\255\255\255\255\255\255\255\255\049\000\255\255\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\255\255\112\000\112\000\049\000\112\000\112\000\255\255\ \255\255\255\255\126\000\126\000\255\255\126\000\126\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\112\000\255\255\255\255\112\000\255\255\055\000\255\255\ \255\255\126\000\055\000\055\000\126\000\255\255\255\255\255\255\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\255\255\255\255\055\000\255\255\048\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\255\255\055\000\055\000\055\000\ \255\255\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\255\255\055\000\059\000\055\000\255\255\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\255\255\255\255\255\255\255\255\255\255\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\255\255\255\255\255\255\255\255\059\000\ \255\255\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\255\255\062\000\062\000\059\000\062\000\ \062\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\062\000\255\255\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \255\255\062\000\062\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\062\000\062\000\062\000\ \062\000\062\000\255\255\255\255\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\255\255\255\255\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\067\000\062\000\ \255\255\067\000\071\000\137\000\140\000\071\000\255\255\255\255\ \137\000\140\000\255\255\255\255\255\255\255\255\255\255\072\000\ \088\000\255\255\072\000\088\000\255\255\255\255\067\000\255\255\ \067\000\255\255\071\000\067\000\071\000\255\255\255\255\071\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\072\000\ \088\000\255\255\088\000\255\255\072\000\088\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\137\000\140\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\069\000\255\255\069\000\255\255\255\255\ \067\000\069\000\069\000\069\000\071\000\255\255\255\255\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\072\000\088\000\069\000\255\255\255\255\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\062\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\255\255\255\255\255\255\069\000\125\000\125\000\ \255\255\255\255\125\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\100\000\255\255\255\255\100\000\125\000\255\255\125\000\ \125\000\125\000\255\255\255\255\125\000\125\000\125\000\255\255\ \255\255\125\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\100\000\255\255\255\255\255\255\081\000\100\000\125\000\ \081\000\255\255\125\000\255\255\255\255\255\255\255\255\255\255\ \255\255\137\000\140\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\081\000\255\255\081\000\ \255\255\079\000\081\000\255\255\067\000\079\000\079\000\255\255\ \071\000\125\000\255\255\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\072\000\088\000\079\000\ \255\255\255\255\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\081\000\ \079\000\079\000\079\000\100\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\085\000\081\000\ \085\000\079\000\255\255\255\255\085\000\085\000\085\000\255\255\ \255\255\255\255\085\000\085\000\085\000\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\255\255\255\255\085\000\255\255\ \255\255\085\000\085\000\085\000\085\000\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\255\255\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\125\000\089\000\255\255\ \085\000\089\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\100\000\ \255\255\255\255\255\255\255\255\255\255\255\255\089\000\255\255\ \089\000\255\255\255\255\089\000\105\000\255\255\255\255\105\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\081\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\105\000\255\255\255\255\255\255\ \255\255\105\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \089\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \094\000\255\255\255\255\255\255\094\000\094\000\255\255\255\255\ \255\255\255\255\094\000\094\000\094\000\094\000\094\000\094\000\ \094\000\094\000\094\000\094\000\255\255\255\255\094\000\255\255\ \089\000\094\000\094\000\094\000\094\000\094\000\094\000\094\000\ \094\000\094\000\094\000\094\000\094\000\094\000\094\000\094\000\ \094\000\094\000\094\000\094\000\094\000\094\000\094\000\094\000\ \094\000\094\000\094\000\094\000\094\000\094\000\105\000\094\000\ \094\000\094\000\255\255\094\000\094\000\094\000\094\000\094\000\ \094\000\094\000\094\000\094\000\094\000\094\000\094\000\094\000\ \094\000\094\000\094\000\094\000\094\000\094\000\094\000\094\000\ \094\000\094\000\094\000\094\000\094\000\255\255\255\255\255\255\ \094\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\117\000\117\000\255\255\117\000\ \117\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\117\000\089\000\117\000\117\000\255\255\ \255\255\255\255\117\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\117\000\117\000\117\000\117\000\117\000\ \117\000\117\000\117\000\117\000\117\000\117\000\255\255\255\255\ \255\255\255\255\105\000\117\000\117\000\117\000\117\000\117\000\ \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ \117\000\255\255\117\000\255\255\117\000\117\000\117\000\117\000\ \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ \117\000\117\000\117\000\117\000\117\000\117\000\128\000\255\255\ \255\255\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\255\255\255\255\255\255\255\255\255\255\ \255\255\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\255\255\255\255\255\255\255\255\ \128\000\255\255\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ \128\000\128\000\128\000\128\000\255\255\255\255\255\255\128\000\ \129\000\255\255\255\255\129\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\255\255\255\255\ \255\255\255\255\255\255\129\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\255\255\255\255\ \255\255\255\255\129\000\117\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ \129\000\129\000\129\000\129\000\129\000\129\000\255\255\255\255\ \255\255\129\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255"; Lexing.lex_base_code = ""; Lexing.lex_backtrk_code = ""; Lexing.lex_default_code = ""; Lexing.lex_trans_code = ""; Lexing.lex_check_code = ""; Lexing.lex_code = ""; } let rec lex_main state lexbuf = __ocaml_lex_lex_main_rec state lexbuf 0 and __ocaml_lex_lex_main_rec state lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 669 "omake_ast_lex.mll" ( let loc = state.current_loc in let _ = lexeme_loc state lexbuf in set_next_line state lexbuf; Omake_ast_parse.TokEol loc ) # 1415 "omake_ast_lex.ml" | 1 -> # 675 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in TokWhite (s, loc) ) # 1422 "omake_ast_lex.ml" | 2 -> # 688 "omake_ast_lex.mll" ( lexeme_name state lexbuf ) # 1427 "omake_ast_lex.ml" | 3 -> # 690 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in TokInt (s, loc) ) # 1434 "omake_ast_lex.ml" | 4 -> # 694 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in TokFloat (s, loc) ) # 1441 "omake_ast_lex.ml" | 5 -> # 698 "omake_ast_lex.mll" ( lexeme_key state lexbuf ) # 1446 "omake_ast_lex.ml" | 6 -> # 700 "omake_ast_lex.mll" ( let id, loc = lexeme_string state lexbuf in let mode = ModeQuote id in push_mode state mode; TokBeginQuoteString (id, loc) ) # 1455 "omake_ast_lex.ml" | 7 -> # 707 "omake_ast_lex.mll" ( let id, loc = lexeme_string state lexbuf in let id = String.sub id 1 (pred (String.length id)) in (* GS TODO: use "as" *) let mode = ModeString id in push_mode state mode; TokBeginQuote ("", loc) ) # 1466 "omake_ast_lex.ml" | 8 -> # 715 "omake_ast_lex.mll" ( let id, _ = lexeme_string state lexbuf in let id = String.sub id 1 (pred (String.length id)) in (* GS TODO: use "as" *) let s, loc = lex_literal state (Buffer.create 32) id lexbuf in (* GS: lex_literal is a sublexer. Returns the quoted string *) TokStringQuote (s, loc) ) # 1477 "omake_ast_lex.ml" | 9 -> # 724 "omake_ast_lex.mll" ( let strategy, id, _ = lexeme_dollar_pipe state lexbuf in let s, loc = lex_literal state (Buffer.create 32) id lexbuf in TokVarQuote (strategy, s, loc) ) # 1485 "omake_ast_lex.ml" | 10 -> # 730 "omake_ast_lex.mll" ( lexeme_var state lexbuf ) # 1490 "omake_ast_lex.ml" | 11 -> # 733 "omake_ast_lex.mll" ( lexeme_dollar state lexbuf ) # 1495 "omake_ast_lex.ml" | 12 -> # 736 "omake_ast_lex.mll" ( lexeme_char state lexbuf ) # 1500 "omake_ast_lex.ml" | 13 -> # 739 "omake_ast_lex.mll" ( lexeme_special_string state lexbuf ) # 1505 "omake_ast_lex.ml" | 14 -> # 741 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in TokNamedColon (s, loc) ) # 1512 "omake_ast_lex.ml" | 15 -> # 745 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in TokString (s, loc) ) # 1519 "omake_ast_lex.ml" | 16 -> # 749 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in TokString (s, loc) ) # 1526 "omake_ast_lex.ml" | 17 -> # 753 "omake_ast_lex.mll" ( let s, loc = lexeme_esc state lexbuf in TokStringQuote (s, loc) ) # 1533 "omake_ast_lex.ml" | 18 -> # 757 "omake_ast_lex.mll" ( let loc = lexeme_loc state lexbuf in set_next_line state lexbuf; state.current_prompt <- "\\"; state.current_fill_ok <- true; TokString (" ", loc) ) # 1543 "omake_ast_lex.ml" | 19 -> # 764 "omake_ast_lex.mll" ( let loc = lexeme_loc state lexbuf in match state.current_token with TokEol _ | TokEof _ -> TokEof loc | _ -> TokEol loc ) # 1555 "omake_ast_lex.ml" | 20 -> # 773 "omake_ast_lex.mll" ( let s, _ = lexeme_string state lexbuf in syntax_error state ("illegal character: " ^ String.escaped s) lexbuf ) # 1562 "omake_ast_lex.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_lex_main_rec state lexbuf __ocaml_lex_state and lex_quote state lexbuf = __ocaml_lex_lex_quote_rec state lexbuf 67 and __ocaml_lex_lex_quote_rec state lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 787 "omake_ast_lex.mll" ( set_next_line state lexbuf; syntax_error state "unterminated string" lexbuf ) # 1576 "omake_ast_lex.ml" | 1 -> # 792 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in Omake_ast_parse.TokString (s, loc) ) # 1583 "omake_ast_lex.ml" | 2 -> # 796 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in match state.current_mode with ModeQuote s' when s' = s -> pop_mode state; TokEndQuoteString (s, loc) | _ -> TokString (s, loc) ) # 1595 "omake_ast_lex.ml" | 3 -> # 805 "omake_ast_lex.mll" ( let loc = lexeme_loc state lexbuf in TokString ("$", loc) ) # 1602 "omake_ast_lex.ml" | 4 -> # 809 "omake_ast_lex.mll" ( lexeme_var state lexbuf ) # 1607 "omake_ast_lex.ml" | 5 -> # 811 "omake_ast_lex.mll" ( push_dollar state ModeNormal; lexeme_dollar state lexbuf ) # 1614 "omake_ast_lex.ml" | 6 -> # 815 "omake_ast_lex.mll" ( let s, loc = lexeme_esc state lexbuf in TokString (s, loc) ) # 1621 "omake_ast_lex.ml" | 7 -> # 819 "omake_ast_lex.mll" ( let loc = lexeme_loc state lexbuf in set_next_line state lexbuf; state.current_fill_ok <- true; TokString ("", loc) ) # 1630 "omake_ast_lex.ml" | 8 -> # 825 "omake_ast_lex.mll" ( syntax_error state "unterminated string" lexbuf ) # 1635 "omake_ast_lex.ml" | 9 -> # 827 "omake_ast_lex.mll" ( let s, _ = lexeme_string state lexbuf in syntax_error state ("illegal character in string constant: " ^ String.escaped s) lexbuf ) # 1642 "omake_ast_lex.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_lex_quote_rec state lexbuf __ocaml_lex_state and lex_string state lexbuf = __ocaml_lex_lex_string_rec state lexbuf 81 and __ocaml_lex_lex_string_rec state lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 841 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in Omake_ast_parse.TokString (s, loc) ) # 1656 "omake_ast_lex.ml" | 1 -> # 845 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in match state.current_mode with ModeString s' when s' = s -> pop_mode state; TokEndQuote ("", loc) | _ -> TokString (s, loc) ) # 1668 "omake_ast_lex.ml" | 2 -> # 854 "omake_ast_lex.mll" ( let loc = lexeme_loc state lexbuf in TokString ("$", loc) ) # 1675 "omake_ast_lex.ml" | 3 -> # 858 "omake_ast_lex.mll" ( lexeme_var state lexbuf ) # 1680 "omake_ast_lex.ml" | 4 -> # 860 "omake_ast_lex.mll" ( push_dollar state ModeNormal; lexeme_dollar state lexbuf ) # 1687 "omake_ast_lex.ml" | 5 -> # 864 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in let () = match state.current_mode with ModeString s -> push_mode state (ModeSkipString s) | _ -> (* GS CHECK: When is this possible? *) () in set_next_line state lexbuf; state.current_fill_ok <- true; TokString (s, loc) ) # 1704 "omake_ast_lex.ml" | 6 -> # 878 "omake_ast_lex.mll" ( let loc = lexeme_loc state lexbuf in let () = match state.current_mode with ModeString s -> push_mode state (ModeSkipString s) | _ -> () in set_next_line state lexbuf; state.current_fill_ok <- true; TokString ("", loc) ) # 1720 "omake_ast_lex.ml" | 7 -> # 891 "omake_ast_lex.mll" ( syntax_error state "unterminated string" lexbuf ) # 1725 "omake_ast_lex.ml" | 8 -> # 893 "omake_ast_lex.mll" ( let s, _ = lexeme_string state lexbuf in syntax_error state ("illegal character: " ^ String.escaped s) lexbuf ) # 1732 "omake_ast_lex.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_lex_string_rec state lexbuf __ocaml_lex_state and lex_skip_string state lexbuf = __ocaml_lex_lex_skip_string_rec state lexbuf 96 and __ocaml_lex_lex_skip_string_rec state lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 902 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in pop_mode state; match state.current_mode with ModeString s' when s' = s -> pop_mode state; Omake_ast_parse.TokEndQuote ("", loc) | _ -> TokString ("", loc) ) # 1752 "omake_ast_lex.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_lex_skip_string_rec state lexbuf __ocaml_lex_state and lex_literal state buf equote lexbuf = __ocaml_lex_lex_literal_rec state buf equote lexbuf 100 and __ocaml_lex_lex_literal_rec state buf equote lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 918 "omake_ast_lex.mll" ( let s, _ = lexeme_string state lexbuf in set_next_line state lexbuf; state.current_fill_ok <- true; Buffer.add_string buf s; lex_literal_skip state buf equote lexbuf ) # 1769 "omake_ast_lex.ml" | 1 -> # 925 "omake_ast_lex.mll" ( let s, _ = lexeme_string state lexbuf in Buffer.add_string buf s; lex_literal state buf equote lexbuf ) # 1777 "omake_ast_lex.ml" | 2 -> # 930 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in if s = equote then let s = Buffer.contents buf in s, loc else begin Buffer.add_string buf s; lex_literal state buf equote lexbuf end ) # 1791 "omake_ast_lex.ml" | 3 -> # 941 "omake_ast_lex.mll" ( syntax_error state "unterminated string" lexbuf ) # 1796 "omake_ast_lex.ml" | 4 -> # 943 "omake_ast_lex.mll" ( let s, _ = lexeme_string state lexbuf in syntax_error state ("illegal character: " ^ String.escaped s) lexbuf ) # 1803 "omake_ast_lex.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_lex_literal_rec state buf equote lexbuf __ocaml_lex_state and lex_literal_skip state buf equote lexbuf = __ocaml_lex_lex_literal_skip_rec state buf equote lexbuf 108 and __ocaml_lex_lex_literal_skip_rec state buf equote lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 949 "omake_ast_lex.mll" ( let s, loc = lexeme_string state lexbuf in if s = equote then let s = Buffer.contents buf in s, loc else lex_literal state buf equote lexbuf ) # 1821 "omake_ast_lex.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_lex_literal_skip_rec state buf equote lexbuf __ocaml_lex_state and lex_indent state lexbuf = __ocaml_lex_lex_indent_rec state lexbuf 112 and __ocaml_lex_lex_indent_rec state lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 963 "omake_ast_lex.mll" ( set_next_line state lexbuf; state.current_fill_ok <- true; lex_indent state lexbuf ) # 1836 "omake_ast_lex.ml" | 1 -> # 968 "omake_ast_lex.mll" ( let s, _ = lexeme_string state lexbuf in let indent = indent_of_string s in indent ) # 1844 "omake_ast_lex.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_lex_indent_rec state lexbuf __ocaml_lex_state and lex_deps lexbuf = __ocaml_lex_lex_deps_rec lexbuf 117 and __ocaml_lex_lex_deps_rec lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 981 "omake_ast_lex.mll" ( let s, loc = lexeme_pos lexbuf in Omake_ast_parse.TokString (s, loc) ) # 1858 "omake_ast_lex.ml" | 1 -> # 985 "omake_ast_lex.mll" ( let _, loc = lexeme_pos lexbuf in TokString (":", loc) ) # 1865 "omake_ast_lex.ml" | 2 -> # 989 "omake_ast_lex.mll" ( let s, loc = lexeme_pos lexbuf in TokColon (s, loc) ) # 1872 "omake_ast_lex.ml" | 3 -> # 993 "omake_ast_lex.mll" ( let s, loc = lexeme_pos lexbuf in let buf = Buffer.create 64 in Buffer.add_string buf s; lex_deps_quote s buf lexbuf; TokString (Buffer.contents buf, loc) ) # 1882 "omake_ast_lex.ml" | 4 -> # 1001 "omake_ast_lex.mll" ( let _, loc = lexeme_pos lexbuf in TokEol loc ) # 1889 "omake_ast_lex.ml" | 5 -> # 1005 "omake_ast_lex.mll" ( let s, loc = lexeme_pos lexbuf in let s = String.make 1 s.[1] in TokStringQuote (s, loc) ) # 1897 "omake_ast_lex.ml" | 6 -> # 1010 "omake_ast_lex.mll" ( let _, loc = lexeme_pos lexbuf in TokWhite (" ", loc) ) # 1904 "omake_ast_lex.ml" | 7 -> # 1014 "omake_ast_lex.mll" ( let s, loc = lexeme_pos lexbuf in TokString (s, loc) ) # 1911 "omake_ast_lex.ml" | 8 -> # 1018 "omake_ast_lex.mll" ( let _, loc = lexeme_pos lexbuf in TokEof loc ) # 1918 "omake_ast_lex.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_lex_deps_rec lexbuf __ocaml_lex_state and lex_deps_quote term buf lexbuf = __ocaml_lex_lex_deps_quote_rec term buf lexbuf 137 and __ocaml_lex_lex_deps_quote_rec term buf lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 1026 "omake_ast_lex.mll" ( let s, _ = lexeme_pos lexbuf in Buffer.add_string buf s; lex_deps_quote term buf lexbuf ) # 1933 "omake_ast_lex.ml" | 1 -> # 1031 "omake_ast_lex.mll" ( let s, _ = lexeme_pos lexbuf in Buffer.add_string buf s; if s <> term then lex_deps_quote term buf lexbuf ) # 1942 "omake_ast_lex.ml" | 2 -> # 1038 "omake_ast_lex.mll" ( raise Parsing.Parse_error ) # 1947 "omake_ast_lex.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_lex_deps_quote_rec term buf lexbuf __ocaml_lex_state ;; # 1040 "omake_ast_lex.mll" (************************************************************************ * Prompts. *) (* * Lex and parse a line for the shell. *) let tabstop = 3 let prompt_ext s = s ^ "> " (* Prune the prompt to a reasonable length *) let prompt_prune prompt indent = let max_len = 8 in let s = Bytes.make (indent * tabstop + max_len + 2) ' ' in let length = String.length prompt in if length > max_len then begin Bytes.blit_string prompt 0 s 0 max_len; Bytes.set s max_len '>' end else Bytes.blit_string prompt 0 s 0 length; Bytes.to_string s let prompt_indent prompt root indent = if root then prompt else prompt_prune prompt indent let prompt_string state root nest e = let prompt = prompt_ext (Omake_ast_util.key_of_exp e) in if state.is_interactive && root then Lm_printf.printf "%s%s@?" (prompt_prune prompt nest) state.current_buffer; prompt (* * Parser for the body of an expression. *) let body_parser state body = match body with Omake_ast.NoBody -> None | OptBody -> if state.is_interactive then None else Some Omake_ast_parse.shell | ColonBody -> Some Omake_ast_parse.shell | ArrayBody -> Some Omake_ast_parse.string (************************************************************************ * Lexing input. *) (* * Copy into the lexbuf. *) let lex_fill state buf len = let { current_buffer = buffer; current_index = index; _ } = state in let length = String.length buffer in let amount = min (length - index) len in if amount = 0 then state.current_eof <- true else begin String.blit buffer index buf 0 amount; state.current_index <- index + amount end; amount (* * Refill the buffer using the readline function. *) let state_refill state = let { current_fill_ok = fill_ok; current_prompt = prompt; readline = readline; _ } = state in if fill_ok then let line = readline prompt in let line = if state.is_interactive && line = ".\n" then "" else line in state.current_buffer <- line; state.current_index <- 0; state.current_fill_ok <- false (* * Lexer function to refill the buffer. * GS. This is for Lexing.from_function. *) let lex_refill state buf len = let { current_buffer = buffer; current_index = index; _ } = state in let length = String.length buffer in let amount = length - index in if amount = 0 then state_refill state; lex_fill state buf len (************************************************************************ * Main lexer. *) (* * Get the input. *) let lex_line state lexbuf = let tok = match state.current_mode with ModeNormal -> lex_main state lexbuf | ModeString _ -> lex_string state lexbuf | ModeSkipString _ -> lex_skip_string state lexbuf | ModeQuote _ -> lex_quote state lexbuf in if !debug_lex then Lm_printf.eprintf "Token: %a@." pp_print_token tok; state.current_token <- tok; tok (************************************************************************ * Parse main loop. *) (* * Make sure the lexbuf is valid. *) let parse_refill state prompt root nest = if state.current_eof then begin let lexbuf = Lexing.from_function (lex_refill state) in state.current_eof <- false; state.current_fill_ok <- true; state.current_prompt <- prompt_indent prompt root nest; state.current_lexbuf <- lexbuf; state.current_lexmode <- LexModeInitial; state.current_off <- 0 end (* * Get the current indentation level. *) let parse_indent state prompt root nest = parse_refill state prompt root nest; match state.current_lexmode with LexModeInitial -> let indent = (* Interactive shell ignores indentation *) if state.is_interactive then nest else lex_indent state state.current_lexbuf in if !debug_lex then Lm_printf.eprintf "indent: %d@." indent; state.current_lexmode <- LexModeNormal indent; indent | LexModeNormal indent -> indent (* GS. In the following, parse = Omake_ast_parse.shell, i.e. the ocamlyacc generated parser *) (* * Parse a single expression. * GS. an "expression" is not just a $-expression, but any code block, which * may span several lines. *) let rec parse_exp state parse prompt root nest = let indent = parse_indent state prompt root nest in if indent > state.current_indent then syntax_error state "illegal indentation" state.current_lexbuf else if indent < state.current_indent then raise End_of_file else parse_exp_indent state parse prompt root nest and parse_exp_indent state parse _ root nest = (* GS: after the indentation... *) let code, e = try parse (lex_line state) state.current_lexbuf with Parsing.Parse_error -> parse_error state in (* GS: e is the parsed expression *) let code = Omake_ast_util.scan_body_flag code e in let parse = body_parser state code in (* GS. parse is now None, or Some Omake_ast_parse.shell or .string *) match parse with Some parse -> let prompt = prompt_string state root nest e in let body = parse_body state parse prompt nest in let e = Omake_ast_util.update_body e code body in (match Omake_ast_util.can_continue e with Some prompt -> (try e :: parse_exp state parse (prompt_ext prompt) false nest with End_of_file -> [e]) | None -> [e]) | None -> [e] and parse_body state parse prompt nest = let nest = succ nest in let indent = parse_indent state prompt false nest in (* GS. The body must be further indented, otherwise it is not a body of the preceding expr *) if indent > state.current_indent then begin push_mode state ModeNormal; state.current_indent <- indent; parse_body_indent state parse prompt nest [] end else [] and parse_body_indent state parse prompt nest el = (* GS TODO: reformulate with "match ... with exception" *) let e = try ParseExp (parse_exp state parse prompt false nest) with End_of_file -> if state.is_interactive then Lm_printf.printf ".@."; pop_mode state; ParseEOF | Omake_value_type.OmakeException _ as exn when state.is_interactive -> Lm_printf.eprintf "%a@." Omake_exn_print.pp_print_exn exn; ParseError in match e with ParseExp e -> parse_body_indent state parse prompt nest (List.rev_append e el) | ParseError -> parse_body_indent state parse prompt nest el | ParseEOF -> List.rev el (* * Parse a file. * GS: Entry point *) let parse_ast name = let inx = open_in name in let readline _ = try input_line inx ^ "\n" with End_of_file -> "" in let state = create name readline in let el = parse_body_indent state Omake_ast_parse.shell "" 0 [] in close_in inx; el (* * Parse a string. * GS: Entry point *) let parse_string s = let len = String.length s in let index = ref 0 in let readline _ = let start = !index in let rec search i = if i = len then if start < i then begin index := i; String.sub s start (i - start) ^ "\n" end else raise End_of_file else if s.[i] = '\n' then begin index := i + 1; String.sub s start (i - start + 1) end else search (succ i) in search start in let state = create "-" readline in parse_body_indent state Omake_ast_parse.shell "" 0 [] (* * Parse an expression. *) let create_shell () = let state = create "-" Lm_readline.readline in state.is_interactive <- Lm_readline.is_interactive (); state (* * Copy the state, if an exception happens, then * restore the initial state. *) let parse_shell state prompt = let stack = save_mode state in state.current_fill_ok <- true; try parse_exp state Omake_ast_parse.shell prompt true 0 with exn -> Lm_readline.flush (); restore_mode state stack; state.current_buffer <- ""; state.current_index <- 0; raise exn (* * Just dependency analysis. *) let parse_deps name = let inx = open_in name in let lexbuf = Lexing.from_channel inx in let deps = try Omake_ast_parse.deps lex_deps lexbuf with exn -> close_in inx; Lm_printf.eprintf "%s: char %d: scanner dependency syntax error@." name (Lexing.lexeme_end lexbuf); raise exn in close_in inx; deps # 2303 "omake_ast_lex.ml" omake-0.10.3/src/env/omake_exp_lex.ml0000644000175000017500000002321213177364666016067 0ustar gerdgerd(* * Secondary lexer for expressions. * * GS: This is called after the first lexer/parser (Omake_ast_lex) and before * the translation of the AST to the IR (Omake_ir_ast). It is a transformation * of the AST. * This implements "program mode", an undocumented feature. *) open Lm_symbol open Omake_ast open Omake_symbol open Omake_ast_util open Omake_exp_parse open Omake_value_type module Pos = Omake_pos.Make (struct let name = "Omake_shell_lex" end);; open Pos;; (************************************************************************ * Types. *) (* * Token buffer. *) type lexinfo = { mutable lex_exp_list : Omake_ast.exp list; mutable lex_loc : Lm_location.t } let create_lexinfo loc tokens = { lex_exp_list = tokens; lex_loc = loc } (************************************************************************ * Utilities. *) (* * Locations. *) (* let shell_sym = Lm_symbol.add "shell" *) let syntax_error s loc = raise (OmakeException (loc_exp_pos loc, SyntaxError s)) (************************************************************************ * Lexing. *) (* * Various operators. *) let lex_op s loc = match s with "(" -> TokLeftParen loc | ")" -> TokRightParen loc | "," -> TokComma loc | ";" -> TokSemi loc | "=" -> TokEq loc | "." -> TokDot loc | "+" -> TokPlus loc | "-" -> TokMinus loc | "*" -> TokStar loc | "/" -> TokSlash loc | "<" -> TokLt loc | ">" -> TokGt loc | "^" -> TokHat loc | "&" -> TokAmp loc | "|" -> TokPipe loc | "::" -> TokColonColon loc | "<<" -> TokLsl loc | ">>" -> TokAsr loc | ">>>" -> TokLsr loc | "&&" -> TokAnd loc | "||" -> TokOr loc | "=>" -> TokArrow loc | _ -> syntax_error ("unexpected operator: " ^ s) loc (* * Some identifier are operators. *) let lex_id s loc = try TokInt (int_of_string s, loc) with Failure _ -> try TokFloat (float_of_string s, loc) with Failure _ -> match s with "" -> raise (Invalid_argument "Omake_exp_lex.lex_id") | "-" -> TokMinus loc | "[" -> TokLeftBrack loc | "]" -> TokRightBrack loc | _ -> match s.[0] with '~' | '?' -> TokKey (Lm_symbol.add (String.sub s 1 (String.length s - 1)), loc) | _ -> TokId (Lm_symbol.add s, loc) (* * Translate an expression to a token. *) let rec lex_tok lexinfo e = match e with IntExp (i, loc) -> TokInt (i, loc) | FloatExp (x, loc) -> TokFloat (x, loc) | StringOpExp (s, loc) -> lex_op s loc | StringIdExp (s, loc) -> lex_id s loc | StringIntExp (s, loc) -> TokInt (int_of_string s, loc) | StringFloatExp (s, loc) -> TokFloat (float_of_string s, loc) | StringKeywordExp (s, loc) -> TokId (Lm_symbol.add s, loc) | StringWhiteExp _ -> lex_main lexinfo | StringOtherExp (s, loc) -> syntax_error s loc | SequenceExp (el, _) -> lexinfo.lex_exp_list <- el @ lexinfo.lex_exp_list; lex_main lexinfo | NullExp _ | QuoteExp _ | QuoteStringExp _ | ArrayExp _ | ApplyExp _ | SuperApplyExp _ | MethodApplyExp _ | CommandExp _ | VarDefExp _ | VarDefBodyExp _ | ObjectDefExp _ | FunDefExp _ | RuleExp _ | BodyExp _ | ShellExp _ | CatchExp _ | ClassExp _ | KeyExp _ | KeyDefExp _ | KeyDefBodyExp _ -> TokExp e and lex_main lexinfo = match lexinfo.lex_exp_list with [] -> TokEof | e :: el -> lexinfo.lex_loc <- loc_of_exp e; lexinfo.lex_exp_list <- el; lex_tok lexinfo e (* * Ignore the lexbuf. *) let lex_main lexinfo _lexbuf = lex_main lexinfo (* * Lexer from a token list. *) let lexbuf = Lexing.from_string "dummy lexbuf" (* GS: tokens: this is actually a list of AST nodes. These are back-translated to tokens (lex_tok), and parsed with Omake_exp_parse.ast_exp. *) let parse loc tokens = let lexinfo = create_lexinfo loc tokens in try Omake_exp_parse.ast_exp (lex_main lexinfo) lexbuf with Parsing.Parse_error -> syntax_error "parse error" lexinfo.lex_loc (************************************************************************ * Translation. *) type mode = ProgramMode | NormalMode let apply_mode mode = function CommandApply -> mode | NormalApply | EagerApply | LazyApply -> NormalMode let languages = "legal languages are (program, make); you said" let language_mode loc _pattern source = let pos = string_pos "language_mode" (loc_exp_pos loc) in if SymbolTable.cardinal source <> 1 || not (SymbolTable.mem source normal_sym) then raise (OmakeException (pos, StringError "illegal language")); match SymbolTable.find source normal_sym with StringIdExp (s, _) -> (match s with "program" -> ProgramMode | "make" -> NormalMode | _ -> raise (OmakeException (pos, StringStringError (languages, s)))) | e -> raise (OmakeException (pos, StringAstError (languages, e))) (* * Perform the ast->ast translation. *) let rec translate_exp mode e = match e with (* This is not an identifier *) NullExp _ | IntExp _ | FloatExp _ | QuoteExp _ | QuoteStringExp _ | ClassExp _ | KeyExp _ -> e (* Single-token processing *) | StringOpExp (_, loc) | StringIdExp (_, loc) | StringIntExp (_, loc) | StringWhiteExp (_, loc) | StringFloatExp (_, loc) | StringOtherExp (_, loc) | StringKeywordExp (_, loc) -> (match mode with ProgramMode -> translate_exp mode (parse loc [e]) | NormalMode -> e) (* Sequences *) | SequenceExp (el, loc) -> (match mode with ProgramMode -> translate_exp mode (parse loc el) | NormalMode -> SequenceExp (translate_exp_list mode el, loc)) | ArrayExp (el, loc) -> ArrayExp (translate_exp_list mode el, loc) | ApplyExp (strategy, v, args, loc) -> ApplyExp (strategy, v, translate_arg_list (apply_mode mode strategy) args, loc) | SuperApplyExp (strategy, v1, v2, args, loc) -> SuperApplyExp (strategy, v1, v2, translate_arg_list (apply_mode mode strategy) args, loc) | MethodApplyExp (strategy, vl, args, loc) -> MethodApplyExp (strategy, vl, translate_arg_list (apply_mode mode strategy) args, loc) | CommandExp (v, e, el, loc) -> CommandExp (v, translate_exp mode e, translate_body mode el, loc) | VarDefExp (vl, kind, flag, e, loc) -> VarDefExp (vl, kind, flag, translate_exp mode e, loc) | VarDefBodyExp (vl, kind, flag, el, loc) -> VarDefBodyExp (vl, kind, flag, translate_body mode el, loc) | ObjectDefExp (vl, flag, el, loc) -> ObjectDefExp (vl, flag, translate_body mode el, loc) | FunDefExp (vl, params, el, loc) -> FunDefExp (vl, translate_param_list mode params, translate_body mode el, loc) | RuleExp (multiple, target, pattern, options, body, loc) -> RuleExp (multiple, translate_exp NormalMode target, translate_exp NormalMode pattern, translate_table_exp NormalMode options, translate_exp_list mode body, loc) | BodyExp (el, loc) -> BodyExp (translate_body mode el, loc) | CatchExp (v1, v2, el, loc) -> CatchExp (v1, v2, translate_body mode el, loc) | KeyDefExp (s, kind, flag, e, loc) -> KeyDefExp (s, kind, flag, translate_exp mode e, loc) | KeyDefBodyExp (s, kind, flag, el, loc) -> KeyDefBodyExp (s, kind, flag, translate_body mode el, loc) | ShellExp (e, loc) -> ShellExp (translate_exp NormalMode e, loc) and translate_exp_list mode el = List.map (translate_exp mode) el (* make-style applications are always in NormalMode *) and translate_arg mode = function KeyArg (v, e) -> KeyArg (v, translate_exp mode e) | ExpArg e -> ExpArg (translate_exp mode e) | ArrowArg (params, e) -> ArrowArg (translate_param_list mode params, translate_exp mode e) and translate_arg_list mode args = List.map (translate_arg mode) args and translate_param mode = function OptionalParam (v, e, loc) -> OptionalParam (v, translate_exp mode e, loc) | RequiredParam _ | NormalParam _ as param -> param and translate_param_list mode params = List.map (translate_param mode) params and translate_table_exp mode table = SymbolTable.map (translate_exp mode) table and translate_body mode el = match el with [] -> [] | e :: el -> match e with (* JYH: this kind of matching is very fragile *) RuleExp (_, SequenceExp ([StringOpExp (".", _); StringIdExp ("LANGUAGE", _)], _), pattern, source, body, loc) -> let new_mode = language_mode loc pattern source in (match body with [] -> translate_body new_mode el | _ :: _ -> CommandExp (section_sym, e, translate_body new_mode body, loc) :: translate_body mode el) | _ -> translate_exp mode e :: translate_body mode el (************************************************************************ * Main function. *) let compile_prog el = let el = flatten_sequence_prog el in let el = translate_body NormalMode el in let el = flatten_string_prog el in el (* * -*- * Local Variables: * End: * -*- *) omake-0.10.3/src/env/omake_exp_parse.mly0000644000175000017500000002006013177364666016600 0ustar gerdgerd/* * Parser for OMakefiles. * * ---------------------------------------------------------------- * * Copyright (C) 2000-2007 Jason Hickey, Caltech * * 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 2 * 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, write to the Free Software * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. * * Author: Jason Hickey * jyh@cs.caltech.edu */ %{ open Lm_location open Omake_ast open Omake_symbol open Omake_ast_util open Omake_value_type module Pos = Omake_pos.Make (struct let name = "Omake_exp_parse" end) open Pos;; (* * Different types of identifiers. *) type id = SimpleId of var | SuperId of var * var | MethodId of var list (* * Identifier stands for an application. *) let make_id_exp (id, loc) = let e = match id with SimpleId v -> ApplyExp (NormalApply, v, [], loc) | SuperId (v1, v2) -> SuperApplyExp (NormalApply, v1, v2, [], loc) | MethodId vars -> MethodApplyExp (NormalApply, vars, [], loc) in e, loc (* * Unary operations. *) let make_unary_exp v (e, loc) = ApplyExp (NormalApply, v, [ExpArg e], loc), loc let make_binary_exp v (e1, loc1) (e2, loc2) = let loc = union_loc loc1 loc2 in ApplyExp (NormalApply, v, [ExpArg e1; ExpArg e2], loc), loc (* * If the function is a null application, add the args. *) let apply_var = Lm_symbol.add ".fun" let make_apply_exp (e, loc) args = match e with ApplyExp (strategy, v, [], _) -> ApplyExp (strategy, v, args, loc), loc | _ -> (* Create a temporary private variable *) SequenceExp ([VarDefExp ([apply_var], DefineString, DefineNormal, e, loc); ApplyExp (NormalApply, apply_var, args, loc)], loc), loc (* * Function parameters from an argument list. *) let get_fun_param = function ExpArg (ApplyExp (NormalApply, v, [], loc)) -> NormalParam (v, loc) | ExpArg e | KeyArg (_, e) | ArrowArg (_, e) -> raise (OmakeException (loc_exp_pos (loc_of_exp e), StringError "illegal parameter")) let get_fun_params = List.map get_fun_param %} /* * Terminators */ %token TokEof /* * Characters. */ %token TokLeftParen %token TokRightParen %token TokLeftBrack %token TokRightBrack %token TokPlus %token TokMinus %token TokStar %token TokSlash %token TokMod %token TokHat %token TokPipe %token TokAmp %token TokLsl %token TokLsr %token TokAsr %token TokAnd %token TokOr %token TokDot %token TokComma %token TokSemi %token TokLe %token TokLt %token TokEq %token TokNeq %token TokGt %token TokGe %token TokColonColon %token TokArrow /* * Words. */ %token TokId %token TokKey %token TokCatch /* * Values. */ %token TokInt %token TokFloat %token TokExp /* * Precedences. */ %left TokSemi %left TokComma %left TokAnd TokOr %left TokPipe %left TokAmp %left TokHat %left TokEq TokNeq %left TokLe TokLt TokGe TokGt %left TokLsl TokLsr TokAsr %left TokPlus TokMinus %left TokStar TokSlash TokMod %right prec_uminus %left TokDot TokLeftBrack TokLeftParen /* * A complete program. */ %start ast_exp %type ast_exp %type exp %% ast_exp: exp TokEof { let e, _ = $1 in e } ; exp: TokInt { let i, loc = $1 in IntExp (i, loc), loc } | TokFloat { let x, loc = $1 in FloatExp (x, loc), loc } | TokExp { let e = $1 in e, loc_of_exp e } | id { make_id_exp $1 } | TokMinus exp %prec prec_uminus { make_unary_exp neg_fun_sym $2 } | exp TokPlus exp { make_binary_exp add_fun_sym $1 $3 } | exp TokMinus exp { make_binary_exp sub_fun_sym $1 $3 } | exp TokStar exp { make_binary_exp mul_fun_sym $1 $3 } | exp TokSlash exp { make_binary_exp div_fun_sym $1 $3 } | exp TokMod exp { make_binary_exp mod_fun_sym $1 $3 } | exp TokHat exp { make_binary_exp lxor_fun_sym $1 $3 } | exp TokPipe exp { make_binary_exp lor_fun_sym $1 $3 } | exp TokAmp exp { make_binary_exp land_fun_sym $1 $3 } | exp TokLsl exp { make_binary_exp lsl_fun_sym $1 $3 } | exp TokLsr exp { make_binary_exp lsr_fun_sym $1 $3 } | exp TokAsr exp { make_binary_exp asr_fun_sym $1 $3 } | exp TokAnd exp { make_binary_exp and_fun_sym $1 $3 } | exp TokOr exp { make_binary_exp or_fun_sym $1 $3 } | exp TokLe exp { make_binary_exp le_fun_sym $1 $3 } | exp TokLt exp { make_binary_exp lt_fun_sym $1 $3 } | exp TokEq exp { make_binary_exp equal_fun_sym $1 $3 } | exp TokNeq exp { make_binary_exp nequal_fun_sym $1 $3 } | exp TokGt exp { make_binary_exp gt_fun_sym $1 $3 } | exp TokGe exp { make_binary_exp ge_fun_sym $1 $3 } | exp TokLeftParen opt_args TokRightParen { make_apply_exp $1 $3 } | exp TokLeftBrack exp TokRightBrack { make_binary_exp nth_fun_sym $3 $1 } | TokLeftParen exp TokRightParen { $2 } | TokLeftBrack opt_exp_list TokRightBrack { let loc = union_loc $1 $3 in ArrayExp ($2, loc), loc } ; id: TokId { let id, loc = $1 in SimpleId id, loc } | TokId TokColonColon TokId { let v1, loc1 = $1 in let v2, loc2 = $3 in let loc = union_loc loc1 loc2 in SuperId (v1, v2), loc } | TokId TokDot rev_path_id { let v1, loc1 = $1 in let vars, loc2 = $3 in let loc = union_loc loc1 loc2 in MethodId (v1 :: vars), loc } ; rev_path_id: TokId { let v, loc = $1 in [v], loc } | rev_path_id TokDot TokId { let path, loc1 = $1 in let v, loc2 = $3 in let loc = union_loc loc1 loc2 in v :: path, loc } ; /* * Expression lists, separated by commas. */ opt_exp_list: /* empty */ { [] } | rev_exp_list opt_semi_or_comma { List.rev $1 } ; rev_exp_list: exp { let e, _ = $1 in [e] } | rev_exp_list semi_or_comma exp { let e, _ = $3 in e :: $1 } ; opt_semi_or_comma: /* empty */ { () } | semi_or_comma { () } ; semi_or_comma: TokSemi { $1 } | TokComma { $1 } ; /* * Argument lists. */ opt_args: /* empty */ { [] } | args { $1 } ; args: rev_args { List.rev $1 } | rev_arrow_args { List.rev $1 } | rev_arrow_args TokComma rev_args { List.rev_append $1 (List.rev $3) } ; rev_arrow_args: arrow_arg { [$1] } | rev_arrow_args TokComma arrow_arg { $3 :: $1 } ; arrow_arg: rev_args TokArrow exp { let e, _ = $3 in ArrowArg (get_fun_params (List.rev $1), e) } ; rev_args: arg { [$1] } | rev_args TokComma arg { $3 :: $1 } ; arg: exp { let e, _ = $1 in ExpArg e } | TokKey { let key, loc = $1 in KeyArg (key, NullExp loc) } | TokKey TokEq exp { let key, _ = $1 in let e, _ = $3 in KeyArg (key, e) } ; omake-0.10.3/src/env/omake_ast_lex.mll0000644000175000017500000011102113177364666016232 0ustar gerdgerd(* * Lexer for the omake language. * This is a little difficult because indentation is * significant, and we want it to work in interactive mode * too. * * GS. Also includes the entry points for parsing: * - parse_ast: parse a file * - parse_string: parse a string *) { include Omake_pos.Make (struct let name = "Omake_ast_lex" end) let debug_lex = Lm_debug.create_debug (**) { debug_name = "debug-ast-lex"; debug_description = "Print tokens as they are scanned"; debug_value = false } (* * Current mode: * ModeNormal: normal lexing mode * ModeString s: parsing a literal string, dollar sequences are still expanded, * s is the quotation delimiter * ModeSkipString s :parsing a literal string, dollar sequences are still expanded, * s is the quotation delimiter, skip the token if it is a quote that is not s * ModeQuote s: parsing a literal string, dollar sequences are still expanded, * escape sequences are allowed, s is the quotation delimiter. * * GS. The main entry is lex_line (below). Depending on the current mode, * a different lexer function is invoked: * * ModeNormal: calls lex_main * ModeString: calls lex_string, for text in $+dquote (e.g. $"") * ModeSkipString: calls lex_skip_string. This is used after newlines inside * $-dquoted-text for checking whether the matching end * quote is following. Fairly technical. * ModeQuote: calls lex_quote, for text after dquote *) type mode = ModeNormal | ModeSkipString of string | ModeString of string | ModeQuote of string (* * The lexing mode. * ModeInitial: lexbuf is ready to be used * ModeIndent i: initial indentation has been scanned * ModeNormal: normal processing * * GS. LexModeInitial means we are at the beginning of the line. LexModeNormal * means that we've just lexed the left indentation. *) type lexmode = LexModeInitial | LexModeNormal of int (* * Parsing results. *) type parse_item = ParseExp of Omake_ast.exp list | ParseError | ParseEOF (* * This is the info for each indentation level. *) type info = { info_mode : mode; info_indent : int; info_parens : int option } (* * State of the lexer. *) type session = { (* The current location *) current_file : Lm_symbol.t; mutable current_line : int; mutable current_off : int; mutable current_loc : Lm_location.t; (* GS TODO: line/off/loc is now tracked by lexbuf (it wasn't in ancient versions of OCaml). Remove this here, and rely on lexbuf only. *) (* The current input buffer *) mutable current_buffer : string; mutable current_index : int; mutable current_prompt : string; mutable current_fill_ok : bool; mutable current_eof : bool; readline : (string -> string); mutable is_interactive : bool; (* The current lexbuf *) mutable current_lexbuf : Lexing.lexbuf; mutable current_lexmode : lexmode; mutable current_token : Omake_ast_parse.token; (* The current mode *) mutable current_mode : mode; mutable current_parens : int option; mutable current_indent : int; mutable current_stack : info list } (************************************************************************ * Printing. NOTICE: if new tokens are added, please update * the token list in omake_gen_parse.ml!!! *) let pp_print_token buf = function Omake_ast_parse.TokEof _ -> Lm_printf.pp_print_string buf "" | TokEol _ -> Lm_printf.pp_print_string buf "" | TokWhite (s, _) -> Format.fprintf buf "whitespace: \"%s\"" s | TokLeftParen (s, _) -> Format.fprintf buf "left parenthesis: %s" s | TokRightParen (s, _) -> Format.fprintf buf "right parenthesis: %s" s | TokArrow (s, _) -> Format.fprintf buf "arrow: %s" s | TokComma (s, _) -> Format.fprintf buf "comma: %s" s | TokColon (s, _) -> Format.fprintf buf "colon: %s" s | TokDoubleColon (s, _) -> Format.fprintf buf "doublecolon: %s" s | TokNamedColon (s, _) -> Format.fprintf buf "named colon: %s" s | TokDollar (s, strategy, _) -> Format.fprintf buf "dollar: %s%a" s Omake_ast_print.pp_print_strategy strategy | TokEq (s, _) -> Format.fprintf buf "equals: %s" s | TokArray (s, _) -> Format.fprintf buf "array: %s" s | TokDot (s, _) -> Format.fprintf buf "dot: %s" s | TokId (s, _) -> Format.fprintf buf "id: %s" s | TokInt (s, _) -> Format.fprintf buf "int: %s" s | TokFloat (s, _) -> Format.fprintf buf "float: %s" s | TokKey (s, _) -> Format.fprintf buf "key: %s" s | TokKeyword (s, _) -> Format.fprintf buf "keyword: %s" s | TokCatch (s, _) -> Format.fprintf buf "catch: %s" s | TokClass (s, _) -> Format.fprintf buf "class: %s" s | TokVar (_, s, _) -> Format.fprintf buf "var: %s" s | TokOp (s, _) -> Format.fprintf buf "op: %s" s | TokString (s, _) -> Format.fprintf buf "string: \"%s\"" (String.escaped s) | TokBeginQuote (s, _) -> Format.fprintf buf "begin-quote: %s" s | TokEndQuote (s, _) -> Format.fprintf buf "end-quote: %s" s | TokBeginQuoteString (s, _) -> Format.fprintf buf "begin-quote-string: %s" s | TokEndQuoteString (s, _) -> Format.fprintf buf "end-quote-string: %s" s | TokStringQuote (s, _) -> Format.fprintf buf "quote: %s" s | TokVarQuote (_, s, _) -> Format.fprintf buf "key: %s" s (* * Set state. *) let create name readline = let loc = Lm_location.bogus_loc name in { current_file = Lm_symbol.add name; current_line = 1; current_off = 0; current_loc = loc; current_buffer = ""; current_index = 0; current_prompt = ">"; current_fill_ok = true; current_eof = true; readline = readline; is_interactive = false; current_lexbuf = Lexing.from_string ""; current_lexmode = LexModeInitial; current_token = TokEof loc; current_mode = ModeNormal; current_parens = None; current_indent = 0; current_stack = [] } (* let set_current_loc state loc = *) (* state.current_loc <- loc *) let current_location state = state.current_loc (* * Advance a line. *) let set_next_line state lexbuf = let { current_line = line; current_file = file; _ } = state in let line = succ line in state.current_line <- line; state.current_off <- Lexing.lexeme_start lexbuf; state.current_loc <- Lm_location.create_loc file line 0 line 0 (* * Save the state. *) let save_mode state = let { current_mode = mode'; current_parens = parens; current_indent = indent; current_stack = stack; _ } = state in let info = { info_mode = mode'; info_parens = parens; info_indent = indent } in info :: stack (* * Restore the state. *) let restore_mode state stack = match stack with info :: stack -> state.current_mode <- info.info_mode; state.current_parens <- info.info_parens; state.current_indent <- info.info_indent; state.current_stack <- stack | [] -> () (* * Push the new mode. *) let push_mode state mode = let stack = save_mode state in state.current_mode <- mode; state.current_parens <- None; state.current_stack <- stack (* * Pop the mode. *) let pop_mode state = restore_mode state state.current_stack (* * We are moving from a quotation to normal mode. * Start collecting parentheses. *) let push_dollar state mode = push_mode state mode; state.current_parens <- Some 0 (* GS. The reason for counting open parentheses (in current_parens) is that a line feed is interpreted differently while there is an open parenthesis. *) (* * Push a paren. *) let push_paren state = let { current_parens = parens ; _} = state in match parens with Some i -> state.current_parens <- Some (succ i) | None -> () (* * When a paren is popped, if the level becomes zero, * then return to the previous mode. *) let pop_paren state = let { current_parens = parens ; _} = state in match parens with Some i -> let i = pred i in if i = 0 then pop_mode state else state.current_parens <- Some i | None -> () (* * Get the location of the current lexeme. * We assume it is all on one line. *) let lexeme_loc state lexbuf = let { current_line = line; current_off = off; current_file = file; _ } = state in let schar = Lexing.lexeme_start lexbuf - off in let echar = Lexing.lexeme_end lexbuf - off in let loc = Lm_location.create_loc file line schar line echar in state.current_loc <- loc; loc (* GS TODO: use Lexing.lexeme_start_p and Lexing.lexeme_end_p instead *) (* * Raise a syntax error exception. *) let parse_error state = let lexbuf = state.current_lexbuf in let loc = lexeme_loc state lexbuf in let print_error buf = Format.fprintf buf "unexpected token: %a" pp_print_token state.current_token in raise (Omake_value_type.OmakeException (loc_exp_pos loc, LazyError print_error)) let syntax_error state s lexbuf = let loc = lexeme_loc state lexbuf in raise (Omake_value_type.OmakeException (loc_exp_pos loc, SyntaxError s)) (* * Get the string in the lexbuf. *) let lexeme_string state lexbuf = let loc = lexeme_loc state lexbuf in let s = Lexing.lexeme lexbuf in s, loc (* * Remove any trailing dots from the string. *) (* let split_nl_string s = *) (* let len = String.length s in *) (* let rec search i = *) (* if i = len then *) (* s, "" *) (* else *) (* match s.[i] with *) (* '\n' *) (* | '\r' -> *) (* search (succ i) *) (* | _ -> *) (* String.sub s 0 i, String.sub s i (len - i) *) (* in *) (* search 0 *) (* * Process a name. *) let lexeme_name state lexbuf = let id, loc = lexeme_string state lexbuf in match id with "if" | "elseif" | "else" | "switch" | "match" | "select" | "case" | "default" | "section" | "include" | "extends" | "import" | "try" | "when" | "finally" | "raise" | "return" | "export" | "open" | "autoload" | "declare" | "value" | "with" | "as" | "while" | "do" | "set" | "program-syntax" -> Omake_ast_parse.TokKeyword (id, loc) | "catch" -> TokCatch (id, loc) | "class" -> TokClass (id, loc) | _ -> TokId (id, loc) let lexeme_key state lexbuf = let id, loc = lexeme_string state lexbuf in Omake_ast_parse.TokKey (id, loc) (* * Get the escaped char. * GS. e.g. "\X" -> "X" *) let lexeme_esc state lexbuf = let s, loc = lexeme_string state lexbuf in String.make 1 s.[1], loc (* * Single character variable. * GS. $x (not $(...)). Also $`x and $,x. *) let lexeme_var state lexbuf = let s, loc = lexeme_string state lexbuf in let strategy, s = match s.[1] with | '`' -> Omake_ast.LazyApply, String.sub s 2 1 | ',' -> EagerApply, String.sub s 2 1 | _ -> NormalApply, String.sub s 1 1 in Omake_ast_parse.TokVar (strategy, s, loc) (* * Dollar sequence. *) let lexeme_dollar_pipe state lexbuf = let s, loc = lexeme_string state lexbuf in let len = String.length s in let strategy, off = if len >= 2 then match s.[1] with '`' -> Omake_ast.LazyApply, 2 | ',' -> EagerApply, 2 | '|' -> NormalApply, 1 | _ -> syntax_error state ("illegal character: " ^ s) lexbuf else NormalApply, 1 in let s = String.sub s off (String.length s - off) in strategy, s, loc (* GS. Unclear why there are two versions of this function. lexeme_dollar seems to be the usual function, for all of $` $, $$ *) let lexeme_dollar state lexbuf = let s, loc = lexeme_string state lexbuf in let len = String.length s in if len >= 2 then match s.[1] with '`' -> Omake_ast_parse.TokDollar (s, LazyApply, loc) | ',' -> TokDollar (s, EagerApply, loc) | '$' -> TokString ("$", loc) | _ -> syntax_error state ("illegal character: " ^ s) lexbuf else TokDollar (s, NormalApply, loc) (* * Special character. * Keep track of paren nesting. *) let lexeme_char state lexbuf = let s, loc = lexeme_string state lexbuf in match s.[0] with '$' -> Omake_ast_parse.TokDollar (s, NormalApply, loc) | ':' -> TokColon (s, loc) | ',' -> TokComma (s, loc) | '=' -> TokEq (s, loc) | '.' -> TokDot (s, loc) | '%' -> TokVar (NormalApply, s, loc) | '(' -> push_paren state; TokLeftParen (s, loc) | ')' -> pop_paren state; TokRightParen (s, loc) | _ -> TokOp (s, loc) (* * Special string. *) let lexeme_special_string state lexbuf = let s, loc = lexeme_string state lexbuf in match s with "=>" -> Omake_ast_parse.TokArrow (s, loc) | "::" -> TokDoubleColon (s, loc) | "+=" -> TokEq (s, loc) | "[]" -> TokArray (s, loc) | _ -> TokOp (s, loc) (* * Count the indentation in a string of characters. *) let indent_of_string s = let len = String.length s in let rec loop col i = if i = len then col else match s.[i] with '\r' | '\n' -> loop 0 (succ i) | '\t' -> loop ((col + 8) land (lnot 7)) (succ i) | _ -> loop (succ col) (succ i) in loop 0 0 (* * Use lexer positions. *) let lexeme_pos lexbuf = let s = Lexing.lexeme lexbuf in let pos1 = Lexing.lexeme_start_p lexbuf in let pos2 = Lexing.lexeme_end_p lexbuf in let { Lexing.pos_fname = file; Lexing.pos_lnum = line1; Lexing.pos_bol = bol1; Lexing.pos_cnum = cnum1 } = pos1 in let { Lexing.pos_lnum = line2; Lexing.pos_bol = bol2; Lexing.pos_cnum = cnum2; _ } = pos2 in let loc = Lm_location.create_loc (Lm_symbol.add file) line1 (cnum1 - bol1) line2 (cnum2 - bol2) in s, loc } (* * White space. * Line is terminated by '\n' or eof, * but be nice to DOS. *) let whitec = [' ' '\t' '\012'] let white = whitec + let opt_white = whitec * let strict_nl = "\r\n" | ['\n' '\r'] let white_nl = opt_white strict_nl let strict_eol = strict_nl | eof (* * Identifiers and keywords. *) let name_prefix = ['_' 'A'-'Z' 'a'-'z' '0'-'9' '@'] let name_suffix = ['_' 'A'-'Z' 'a'-'z' '0'-'9' '-' '~' '@'] let name = name_prefix name_suffix* | '[' | ']' let key = ['~' '?'] name_suffix+ (* GS. Named function arguments, as in OCaml *) (* * Numbers. *) let binary = "0b" ['0'-'1']* let octal = "0o" ['0'-'7']* let decimal = ['0'-'9']+ let hex = "0x" ['0'-'9' 'a'-'f' 'A'-'F']* let integer = binary | octal | decimal | hex let float_exp = ['e' 'E'] ['-' '+']? ['0'-'9']+ let float1 = ['0'-'9']* '.' ['0'-'9'] float_exp? let float2 = ['0'-'9']+ float_exp let float = float1 | float2 (* * Comments begin with a # symbol and continue to end-of-line. * Comments are relaxed w.r.t. leading whitespace. *) let comment = opt_white '#' [^ '\n']* let comment_nl = comment strict_nl let comment_eol = comment strict_eol (* * Quotes. *) let squote = ['\'']+ let dquote = ['"']+ let pipe = ['|']+ let quote = squote | dquote | pipe let quote_opt = quote? (* * Special variables. * GS. This refers to one-character dollar refs, without parentheses. *) let dollar = '$' ['`' ',' '$'] let paren_dollar = '$' ['`' ',']? let special_sym = ['@' '&' '*' '<' '^' '+' '?' 'A'-'Z' 'a'-'z' '_' '0'-'9' '~' '[' ']'] let special_var = paren_dollar special_sym (* * Named colon separators. *) let special_colon = ':' name ':' (* * Escape sequences. *) let esc_char = '\\' ['$' '(' ')' ':' ',' '=' '#' '\\' '\'' '"' ' ' '\t'] let esc_quote = '\\' ['\\' '\'' '"'] let esc_line = '\\' strict_eol (* * Special sequences. *) let special_char = ['$' '(' ')' ':' ',' ';' '=' '.' '%' '+' '-' '*' '/' '<' '>' '^' '&' '|'] let special_string = "=>" | "::" | "+=" | "[]" | "<<" | ">>" | ">>>" | "&&" | "||" | "..." | "[...]" (* * Other stuff that is not names or special characters. *) let other_char = [^ ' ' '\t' '\012' '\n' '\r' '_' 'A'-'Z' 'a'-'z' '0'-'9' '-' '?' '@' '~' '$' '(' ')' ':' ',' ';' '=' '\\' '#' '%' '[' ']' '.' '"' '\'' '<' '>' '^' '|' '&' '*' '/' '+'] let other_drive = ['A'-'Z' 'a'-'z'] ':' ['\\' '/'] let other_prefix = other_char | other_drive let other_special = ['~' '?'] let other_suffix1 = name_suffix | other_prefix | other_special let other_suffix2 = other_prefix | other_special let other = other_prefix other_suffix1 * | other_special other_suffix2 * (* * A string is anything but a quote, dollar, or backslash. *) let string_text = [^ '\'' '"' '$' '\\' '\r' '\n']+ let literal_text = [^ '\'' '"' '|' '\r' '\n']+ (* * Main lexer. *) rule lex_main state = parse white_nl | comment_nl { let loc = state.current_loc in let _ = lexeme_loc state lexbuf in set_next_line state lexbuf; Omake_ast_parse.TokEol loc } | white { let s, loc = lexeme_string state lexbuf in TokWhite (s, loc) } (* Note: many numbers are also identifiers, * like the decimal numbers, etc. We can define the * regular expressions normally, but give precedence * to identifiers. *) (* GS TODO. This doesn't seem to be correct. The regexp for [name] also parses [integer] and some forms of [float]. Because ocamllex picks the first regexp when two regexps match the same string, [name] is always preferred. *) | name { lexeme_name state lexbuf } | integer { let s, loc = lexeme_string state lexbuf in TokInt (s, loc) } | float { let s, loc = lexeme_string state lexbuf in TokFloat (s, loc) } | key (* GS: name prefixed with '?' or '~' (named arguments) *) { lexeme_key state lexbuf } | ['\'' '"'] { let id, loc = lexeme_string state lexbuf in let mode = ModeQuote id in push_mode state mode; TokBeginQuoteString (id, loc) } (* GS. Remember dquote and squote can be several quotes *) | '$' dquote { let id, loc = lexeme_string state lexbuf in let id = String.sub id 1 (pred (String.length id)) in (* GS TODO: use "as" *) let mode = ModeString id in push_mode state mode; TokBeginQuote ("", loc) } | '$' squote { let id, _ = lexeme_string state lexbuf in let id = String.sub id 1 (pred (String.length id)) in (* GS TODO: use "as" *) let s, loc = lex_literal state (Buffer.create 32) id lexbuf in (* GS: lex_literal is a sublexer. Returns the quoted string *) TokStringQuote (s, loc) } (* GS: e.g. $||text||, this is used for map keys *) | paren_dollar pipe { let strategy, id, _ = lexeme_dollar_pipe state lexbuf in let s, loc = lex_literal state (Buffer.create 32) id lexbuf in TokVarQuote (strategy, s, loc) } (* $ plus a single character *) | special_var { lexeme_var state lexbuf } (* other $ *) | dollar { lexeme_dollar state lexbuf } (* $ ( ) : , ; = . % + - * / < > ^ & | *) | special_char { lexeme_char state lexbuf } (* => :: += [] << >> >>> && || ... [...] *) | special_string { lexeme_special_string state lexbuf } | special_colon { let s, loc = lexeme_string state lexbuf in TokNamedColon (s, loc) } | other { let s, loc = lexeme_string state lexbuf in TokString (s, loc) } | '\\' { let s, loc = lexeme_string state lexbuf in TokString (s, loc) } | esc_char { let s, loc = lexeme_esc state lexbuf in TokStringQuote (s, loc) } | esc_line { let loc = lexeme_loc state lexbuf in set_next_line state lexbuf; state.current_prompt <- "\\"; state.current_fill_ok <- true; TokString (" ", loc) } | eof { let loc = lexeme_loc state lexbuf in match state.current_token with TokEol _ | TokEof _ -> TokEof loc | _ -> TokEol loc } | _ { let s, _ = lexeme_string state lexbuf in syntax_error state ("illegal character: " ^ String.escaped s) lexbuf } (* * Inline text. We allow any text, but dollars are expanded, * escape sequences are allowed, and unescaped newlines are * not allowed (this is the normal shell definition of * a quoted string). * * GS: text after double quotes *) and lex_quote state = parse strict_nl { set_next_line state lexbuf; syntax_error state "unterminated string" lexbuf } | '\\' | string_text { let s, loc = lexeme_string state lexbuf in Omake_ast_parse.TokString (s, loc) } | ['\'' '"'] { let s, loc = lexeme_string state lexbuf in match state.current_mode with ModeQuote s' when s' = s -> pop_mode state; TokEndQuoteString (s, loc) | _ -> TokString (s, loc) } | "$$" { let loc = lexeme_loc state lexbuf in TokString ("$", loc) } | special_var { lexeme_var state lexbuf } | paren_dollar { push_dollar state ModeNormal; lexeme_dollar state lexbuf } | esc_quote { let s, loc = lexeme_esc state lexbuf in TokString (s, loc) } | esc_line { let loc = lexeme_loc state lexbuf in set_next_line state lexbuf; state.current_fill_ok <- true; TokString ("", loc) } | eof { syntax_error state "unterminated string" lexbuf } | _ { let s, _ = lexeme_string state lexbuf in syntax_error state ("illegal character in string constant: " ^ String.escaped s) lexbuf } (* * Inline text. We allow any text, but dollars are expanded. * Escape sequence other than an escaped newline are not * processed. * * GS: text after $ + double quotes *) and lex_string state = parse '\\' | string_text { let s, loc = lexeme_string state lexbuf in Omake_ast_parse.TokString (s, loc) } | quote { let s, loc = lexeme_string state lexbuf in match state.current_mode with ModeString s' when s' = s -> pop_mode state; TokEndQuote ("", loc) | _ -> TokString (s, loc) } | "$$" { let loc = lexeme_loc state lexbuf in TokString ("$", loc) } | special_var { lexeme_var state lexbuf } | paren_dollar { push_dollar state ModeNormal; lexeme_dollar state lexbuf } | strict_nl { let s, loc = lexeme_string state lexbuf in let () = match state.current_mode with ModeString s -> push_mode state (ModeSkipString s) | _ -> (* GS CHECK: When is this possible? *) () in set_next_line state lexbuf; state.current_fill_ok <- true; TokString (s, loc) } | esc_line (* GS: Backslash before newline *) { let loc = lexeme_loc state lexbuf in let () = match state.current_mode with ModeString s -> push_mode state (ModeSkipString s) | _ -> () in set_next_line state lexbuf; state.current_fill_ok <- true; TokString ("", loc) } | eof { syntax_error state "unterminated string" lexbuf } | _ { let s, _ = lexeme_string state lexbuf in syntax_error state ("illegal character: " ^ String.escaped s) lexbuf } and lex_skip_string state = parse (* GS. This also matches the empty string, so this rule is always matched. This is a technical sub-lexer of lex_string *) quote_opt { let s, loc = lexeme_string state lexbuf in pop_mode state; match state.current_mode with ModeString s' when s' = s -> pop_mode state; Omake_ast_parse.TokEndQuote ("", loc) | _ -> TokString ("", loc) } (* * Text, but we don't expand variables. * GS. E.g. after $''. Parses until matching '' *) and lex_literal state buf equote = parse strict_nl { let s, _ = lexeme_string state lexbuf in set_next_line state lexbuf; state.current_fill_ok <- true; Buffer.add_string buf s; lex_literal_skip state buf equote lexbuf } | literal_text { let s, _ = lexeme_string state lexbuf in Buffer.add_string buf s; lex_literal state buf equote lexbuf } | quote { let s, loc = lexeme_string state lexbuf in if s = equote then let s = Buffer.contents buf in s, loc else begin Buffer.add_string buf s; lex_literal state buf equote lexbuf end } | eof { syntax_error state "unterminated string" lexbuf } | _ { let s, _ = lexeme_string state lexbuf in syntax_error state ("illegal character: " ^ String.escaped s) lexbuf } and lex_literal_skip state buf equote = parse quote_opt { let s, loc = lexeme_string state lexbuf in if s = equote then let s = Buffer.contents buf in s, loc else lex_literal state buf equote lexbuf } (* * Parse the whitespace at the beginning of the line. *) and lex_indent state = parse comment_eol | white_nl { set_next_line state lexbuf; state.current_fill_ok <- true; lex_indent state lexbuf } | opt_white { let s, _ = lexeme_string state lexbuf in let indent = indent_of_string s in indent } (* * For speed, define a scanner just for dependency files. *) and lex_deps = parse name | white | other_drive | '\\' { let s, loc = lexeme_pos lexbuf in Omake_ast_parse.TokString (s, loc) } | "\\:" { let _, loc = lexeme_pos lexbuf in TokString (":", loc) } | ':' { let s, loc = lexeme_pos lexbuf in TokColon (s, loc) } | ['"' '\''] { let s, loc = lexeme_pos lexbuf in let buf = Buffer.create 64 in Buffer.add_string buf s; lex_deps_quote s buf lexbuf; TokString (Buffer.contents buf, loc) } | white_nl | comment_nl { let _, loc = lexeme_pos lexbuf in TokEol loc } | esc_char { let s, loc = lexeme_pos lexbuf in let s = String.make 1 s.[1] in TokStringQuote (s, loc) } | esc_line { let _, loc = lexeme_pos lexbuf in TokWhite (" ", loc) } | _ { let s, loc = lexeme_pos lexbuf in TokString (s, loc) } | eof { let _, loc = lexeme_pos lexbuf in TokEof loc } and lex_deps_quote term buf = parse '\\' | '\\' ['"' '\''] | [^ '\\' '"' '\'']+ { let s, _ = lexeme_pos lexbuf in Buffer.add_string buf s; lex_deps_quote term buf lexbuf } | ['\'' '"'] { let s, _ = lexeme_pos lexbuf in Buffer.add_string buf s; if s <> term then lex_deps_quote term buf lexbuf } | _ | eof { raise Parsing.Parse_error } { (************************************************************************ * Prompts. *) (* * Lex and parse a line for the shell. *) let tabstop = 3 let prompt_ext s = s ^ "> " (* Prune the prompt to a reasonable length *) let prompt_prune prompt indent = let max_len = 8 in let s = Bytes.make (indent * tabstop + max_len + 2) ' ' in let length = String.length prompt in if length > max_len then begin Bytes.blit_string prompt 0 s 0 max_len; Bytes.set s max_len '>' end else Bytes.blit_string prompt 0 s 0 length; Bytes.to_string s let prompt_indent prompt root indent = if root then prompt else prompt_prune prompt indent let prompt_string state root nest e = let prompt = prompt_ext (Omake_ast_util.key_of_exp e) in if state.is_interactive && root then Lm_printf.printf "%s%s@?" (prompt_prune prompt nest) state.current_buffer; prompt (* * Parser for the body of an expression. *) let body_parser state body = match body with Omake_ast.NoBody -> None | OptBody -> if state.is_interactive then None else Some Omake_ast_parse.shell | ColonBody -> Some Omake_ast_parse.shell | ArrayBody -> Some Omake_ast_parse.string (************************************************************************ * Lexing input. *) (* * Copy into the lexbuf. *) let lex_fill state buf len = let { current_buffer = buffer; current_index = index; _ } = state in let length = String.length buffer in let amount = min (length - index) len in if amount = 0 then state.current_eof <- true else begin String.blit buffer index buf 0 amount; state.current_index <- index + amount end; amount (* * Refill the buffer using the readline function. *) let state_refill state = let { current_fill_ok = fill_ok; current_prompt = prompt; readline = readline; _ } = state in if fill_ok then let line = readline prompt in let line = if state.is_interactive && line = ".\n" then "" else line in state.current_buffer <- line; state.current_index <- 0; state.current_fill_ok <- false (* * Lexer function to refill the buffer. * GS. This is for Lexing.from_function. *) let lex_refill state buf len = let { current_buffer = buffer; current_index = index; _ } = state in let length = String.length buffer in let amount = length - index in if amount = 0 then state_refill state; lex_fill state buf len (************************************************************************ * Main lexer. *) (* * Get the input. *) let lex_line state lexbuf = let tok = match state.current_mode with ModeNormal -> lex_main state lexbuf | ModeString _ -> lex_string state lexbuf | ModeSkipString _ -> lex_skip_string state lexbuf | ModeQuote _ -> lex_quote state lexbuf in if !debug_lex then Lm_printf.eprintf "Token: %a@." pp_print_token tok; state.current_token <- tok; tok (************************************************************************ * Parse main loop. *) (* * Make sure the lexbuf is valid. *) let parse_refill state prompt root nest = if state.current_eof then begin let lexbuf = Lexing.from_function (lex_refill state) in state.current_eof <- false; state.current_fill_ok <- true; state.current_prompt <- prompt_indent prompt root nest; state.current_lexbuf <- lexbuf; state.current_lexmode <- LexModeInitial; state.current_off <- 0 end (* * Get the current indentation level. *) let parse_indent state prompt root nest = parse_refill state prompt root nest; match state.current_lexmode with LexModeInitial -> let indent = (* Interactive shell ignores indentation *) if state.is_interactive then nest else lex_indent state state.current_lexbuf in if !debug_lex then Lm_printf.eprintf "indent: %d@." indent; state.current_lexmode <- LexModeNormal indent; indent | LexModeNormal indent -> indent (* GS. In the following, parse = Omake_ast_parse.shell, i.e. the ocamlyacc generated parser *) (* * Parse a single expression. * GS. an "expression" is not just a $-expression, but any code block, which * may span several lines. *) let rec parse_exp state parse prompt root nest = let indent = parse_indent state prompt root nest in if indent > state.current_indent then syntax_error state "illegal indentation" state.current_lexbuf else if indent < state.current_indent then raise End_of_file else parse_exp_indent state parse prompt root nest and parse_exp_indent state parse _ root nest = (* GS: after the indentation... *) let code, e = try parse (lex_line state) state.current_lexbuf with Parsing.Parse_error -> parse_error state in (* GS: e is the parsed expression *) let code = Omake_ast_util.scan_body_flag code e in let parse = body_parser state code in (* GS. parse is now None, or Some Omake_ast_parse.shell or .string *) match parse with Some parse -> let prompt = prompt_string state root nest e in let body = parse_body state parse prompt nest in let e = Omake_ast_util.update_body e code body in (match Omake_ast_util.can_continue e with Some prompt -> (try e :: parse_exp state parse (prompt_ext prompt) false nest with End_of_file -> [e]) | None -> [e]) | None -> [e] and parse_body state parse prompt nest = let nest = succ nest in let indent = parse_indent state prompt false nest in (* GS. The body must be further indented, otherwise it is not a body of the preceding expr *) if indent > state.current_indent then begin push_mode state ModeNormal; state.current_indent <- indent; parse_body_indent state parse prompt nest [] end else [] and parse_body_indent state parse prompt nest el = (* GS TODO: reformulate with "match ... with exception" *) let e = try ParseExp (parse_exp state parse prompt false nest) with End_of_file -> if state.is_interactive then Lm_printf.printf ".@."; pop_mode state; ParseEOF | Omake_value_type.OmakeException _ as exn when state.is_interactive -> Lm_printf.eprintf "%a@." Omake_exn_print.pp_print_exn exn; ParseError in match e with ParseExp e -> parse_body_indent state parse prompt nest (List.rev_append e el) | ParseError -> parse_body_indent state parse prompt nest el | ParseEOF -> List.rev el (* * Parse a file. * GS: Entry point *) let parse_ast name = let inx = open_in name in let readline _ = try input_line inx ^ "\n" with End_of_file -> "" in let state = create name readline in let el = parse_body_indent state Omake_ast_parse.shell "" 0 [] in close_in inx; el (* * Parse a string. * GS: Entry point *) let parse_string s = let len = String.length s in let index = ref 0 in let readline _ = let start = !index in let rec search i = if i = len then if start < i then begin index := i; String.sub s start (i - start) ^ "\n" end else raise End_of_file else if s.[i] = '\n' then begin index := i + 1; String.sub s start (i - start + 1) end else search (succ i) in search start in let state = create "-" readline in parse_body_indent state Omake_ast_parse.shell "" 0 [] (* * Parse an expression. *) let create_shell () = let state = create "-" Lm_readline.readline in state.is_interactive <- Lm_readline.is_interactive (); state (* * Copy the state, if an exception happens, then * restore the initial state. *) let parse_shell state prompt = let stack = save_mode state in state.current_fill_ok <- true; try parse_exp state Omake_ast_parse.shell prompt true 0 with exn -> Lm_readline.flush (); restore_mode state stack; state.current_buffer <- ""; state.current_index <- 0; raise exn (* * Just dependency analysis. *) let parse_deps name = let inx = open_in name in let lexbuf = Lexing.from_channel inx in let deps = try Omake_ast_parse.deps lex_deps lexbuf with exn -> close_in inx; Lm_printf.eprintf "%s: char %d: scanner dependency syntax error@." name (Lexing.lexeme_end lexbuf); raise exn in close_in inx; deps } (*! * @docoff * * -*- * Local Variables: * Caml-master: "compile" * End: * -*- *) omake-0.10.3/src/env/omake_ast_lex.mli0000644000175000017500000000066713177364666016244 0ustar gerdgerd(** Lexer for OMakefile's *) val debug_lex : bool ref val parse_ast : string -> Omake_ast.prog val parse_string : string -> Omake_ast.prog val parse_deps : string -> (Omake_ast.exp * Omake_ast.exp * Lm_location.t ) list (* * Shell gets its own handle. *) type session val current_location : session -> Lm_location.t val create_shell : unit -> session val parse_shell : session -> string -> Omake_ast.exp list omake-0.10.3/src/env/omake_exp_lex.mli0000644000175000017500000000211613177364666016240 0ustar gerdgerd(* * Secondary lexer for expressions. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2006 Mojave Group, Caltech * * 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 2 * 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, write to the Free Software * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) open Omake_ast val compile_prog : exp list -> exp list (* * -*- * Local Variables: * Fill-column: 100 * End: * -*- * vim:ts=3:et:tw=100 *) omake-0.10.3/src/env/omake_command_digest.mli0000644000175000017500000000041713177364666017553 0ustar gerdgerd (* * Digests. *) val digest_of_exp : Omake_value_type.pos -> Omake_value_type.t list -> Omake_ir.exp -> Omake_command_type.command_digest val digest_of_commands : Omake_value_type.pos -> Omake_env.arg_command_line list -> Omake_command_type.command_digest omake-0.10.3/src/env/omake_ast_parse.mli0000644000175000017500000000316413177364666016561 0ustar gerdgerdtype token = | TokEof of (Lm_location.t) | TokEol of (Lm_location.t) | TokWhite of (string * Lm_location.t) | TokLeftParen of (string * Lm_location.t) | TokRightParen of (string * Lm_location.t) | TokArrow of (string * Lm_location.t) | TokComma of (string * Lm_location.t) | TokColon of (string * Lm_location.t) | TokDoubleColon of (string * Lm_location.t) | TokNamedColon of (string * Lm_location.t) | TokDollar of (string * Omake_ast.apply_strategy * Lm_location.t) | TokEq of (string * Lm_location.t) | TokArray of (string * Lm_location.t) | TokDot of (string * Lm_location.t) | TokId of (string * Lm_location.t) | TokKey of (string * Lm_location.t) | TokKeyword of (string * Lm_location.t) | TokCatch of (string * Lm_location.t) | TokClass of (string * Lm_location.t) | TokOp of (string * Lm_location.t) | TokInt of (string * Lm_location.t) | TokFloat of (string * Lm_location.t) | TokString of (string * Lm_location.t) | TokBeginQuote of (string * Lm_location.t) | TokEndQuote of (string * Lm_location.t) | TokBeginQuoteString of (string * Lm_location.t) | TokEndQuoteString of (string * Lm_location.t) | TokStringQuote of (string * Lm_location.t) | TokVar of (Omake_ast.apply_strategy * string * Lm_location.t) | TokVarQuote of (Omake_ast.apply_strategy * string * Lm_location.t) val deps : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Omake_ast.exp * Omake_ast.exp * Lm_location.t) list val shell : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Omake_ast.body_flag * Omake_ast.exp val string : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Omake_ast.body_flag * Omake_ast.exp omake-0.10.3/src/env/omake_ir_semant.mli0000644000175000017500000000015613177364666016557 0ustar gerdgerd(* Check a program for semantic validity. *) val build_prog : Omake_env.t -> Omake_ir.exp -> Omake_ir.exp omake-0.10.3/src/env/omake_exp_parse.mli0000644000175000017500000000226513177364666016567 0ustar gerdgerdtype token = | TokEof | TokLeftParen of (Lm_location.t) | TokRightParen of (Lm_location.t) | TokLeftBrack of (Lm_location.t) | TokRightBrack of (Lm_location.t) | TokPlus of (Lm_location.t) | TokMinus of (Lm_location.t) | TokStar of (Lm_location.t) | TokSlash of (Lm_location.t) | TokMod of (Lm_location.t) | TokHat of (Lm_location.t) | TokPipe of (Lm_location.t) | TokAmp of (Lm_location.t) | TokLsl of (Lm_location.t) | TokLsr of (Lm_location.t) | TokAsr of (Lm_location.t) | TokAnd of (Lm_location.t) | TokOr of (Lm_location.t) | TokDot of (Lm_location.t) | TokComma of (Lm_location.t) | TokSemi of (Lm_location.t) | TokLe of (Lm_location.t) | TokLt of (Lm_location.t) | TokEq of (Lm_location.t) | TokNeq of (Lm_location.t) | TokGt of (Lm_location.t) | TokGe of (Lm_location.t) | TokColonColon of (Lm_location.t) | TokArrow of (Lm_location.t) | TokId of (Lm_symbol.t * Lm_location.t) | TokKey of (Lm_symbol.t * Lm_location.t) | TokCatch of (Lm_location.t) | TokInt of (int * Lm_location.t) | TokFloat of (float * Lm_location.t) | TokExp of (Omake_ast.exp) val ast_exp : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Omake_ast.exp omake-0.10.3/src/env/omake_exn_print.mli0000644000175000017500000000045513177364666016606 0ustar gerdgerd (* * Exceptions that should be treated as command failures. *) val is_shell_exn : exn -> bool (* * Print an exception. *) val pp_print_exn : exn Lm_printf.t val pp_print_exn_with_backtrace : backtrace:string -> exn Lm_printf.t (* * Generic catcher. *) val catch : ('a -> 'b) -> 'a -> 'b omake-0.10.3/src/env/omake_env.mli0000644000175000017500000005220613177364666015371 0ustar gerdgerd(* * Debugging. *) val debug_scanner : bool ref val debug_implicit : bool ref (* * Type of environments. *) type t (* * Full and partial applications. *) type partial_apply = | FullApply of t * Omake_value_type.t list * Omake_value_type.keyword_value list | PartialApply of Omake_value_type.env * Omake_value_type.param_value list * Omake_value_type.keyword_param_value list * Omake_ir.param list * Omake_value_type.keyword_value list (* * Command lists are used for rule bodies. * They have their environment, a list of sources, * and the actual body. The body is polymorphic * for various kinds of commands. *) type command_info = { command_env : t; command_sources : Omake_node.Node.t list; command_values : Omake_value_type.t list; command_body : Omake_value_type.command list } (* * A rule description. *) and erule = { rule_loc : Lm_location.t; rule_env : t; rule_target : Omake_node.Node.t; rule_effects : Omake_node.NodeSet.t; rule_locks : Omake_node.NodeSet.t; rule_sources : Omake_node.NodeSet.t; rule_scanners : Omake_node.NodeSet.t; rule_match : string option; rule_multiple : Omake_value_type.rule_multiple; rule_commands : command_info list } (* * A listing of all the explicit rules. * * explicit_targets : the collapsed rules for each explicit target * explicit_deps : the table of explicit rules that are just dependencies * explicit_rules : the table of all individual explicit rules * explicit_directories : the environment for each directory in the project *) and erule_info = { explicit_targets : erule Omake_node.NodeTable.t; explicit_deps : (Omake_node.NodeSet.t * Omake_node.NodeSet.t * Omake_node.NodeSet.t) Omake_node.NodeTable.t; (* locks, sources, scanners *) explicit_rules : erule Omake_node.NodeMTable.t; explicit_directories : t Omake_node.DirTable.t } type srule = { srule_loc : Lm_location.t; srule_static : bool; srule_env : t; srule_key : Omake_value_type.t; srule_deps : Omake_node.NodeSet.t; srule_vals : Omake_value_type.t list; srule_exp : Omake_ir.exp } type static_info = StaticRule of srule | StaticValue of Omake_value_type.obj (* * Command lines. *) and arg_command_inst = (Omake_ir.exp, arg_pipe, Omake_value_type.t) Omake_command_type.poly_command_inst and arg_command_line = (t, Omake_ir.exp, arg_pipe, Omake_value_type.t) Omake_command_type.poly_command_line and string_command_inst = (Omake_ir.exp, string_pipe, Omake_value_type.t) Omake_command_type.poly_command_inst and string_command_line = (t, Omake_ir.exp, string_pipe, Omake_value_type.t) Omake_command_type.poly_command_line and apply = t -> Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> (Lm_symbol.t * string) list -> Omake_value_type.t list -> int * t * Omake_value_type.t and value_cmd = (unit, Omake_value_type.t list, Omake_value_type.t list) Omake_shell_type.poly_cmd and value_apply = (Omake_value_type.t list, Omake_value_type.t list, apply) Omake_shell_type.poly_apply and value_group = (unit, Omake_value_type.t list, Omake_value_type.t list, Omake_value_type.t list, apply) Omake_shell_type.poly_group and value_pipe = (unit, Omake_value_type.t list, Omake_value_type.t list, Omake_value_type.t list, apply) Omake_shell_type.poly_pipe and arg_cmd = (Omake_command_type.arg Omake_shell_type.cmd_exe, Omake_command_type.arg, Omake_command_type.arg) Omake_shell_type.poly_cmd and arg_apply = (Omake_value_type.t, Omake_command_type.arg, apply) Omake_shell_type.poly_apply and arg_group = (Omake_command_type.arg Omake_shell_type.cmd_exe, Omake_command_type.arg, Omake_value_type.t, Omake_command_type.arg, apply) Omake_shell_type.poly_group and arg_pipe = (Omake_command_type.arg Omake_shell_type.cmd_exe, Omake_command_type.arg, Omake_value_type.t, Omake_command_type.arg, apply) Omake_shell_type.poly_pipe and string_cmd = (Omake_shell_type.simple_exe, string, string) Omake_shell_type.poly_cmd and string_apply = (Omake_value_type.t, string, apply) Omake_shell_type.poly_apply and string_group = (Omake_shell_type.simple_exe, string, Omake_value_type.t, string, apply) Omake_shell_type.poly_group and string_pipe = (Omake_shell_type.simple_exe, string, Omake_value_type.t, string, apply) Omake_shell_type.poly_pipe (* * Command line parsing. *) type lexer = string -> int -> int -> int option type tok = TokString of Omake_value_type.t | TokToken of string | TokGroup of tok list (* * Type of execution servers. *) type pid = InternalPid of int | ExternalPid of int | ResultPid of int * t * Omake_value_type.t type exec = (arg_command_line, pid, Omake_value_type.t) Omake_exec.Exec.t (* * Ordering info is abstract. *) type ordering_info (* * Inclusion scope is usually Pervasives, * but it may include everything in scope. *) type include_scope = IncludePervasives | IncludeAll (* Target directories, compressed to a small int *) type target_dir (* * Check if command list does not contain anything to execute. *) val commands_are_trivial : command_info list -> bool (* * Convert a target to a raw string. *) val string_of_target : t -> Omake_value_type.target -> string (* * This takes the starting directory. *) val create : Omake_options.t -> string -> exec -> Omake_cache.t -> t (* * Pervasives management. *) val venv_set_pervasives : t -> unit val venv_get_pervasives : t -> Omake_node.Node.t -> t (* * Variables in scope. *) val venv_include_scope : t -> include_scope -> Omake_ir.senv (* * Fork, so that a thread can work on a private copy in peace. *) val venv_fork : t -> t val venv_unfork : t -> t -> t (* * Global values. *) val venv_exec : t -> exec val venv_cache : t -> Omake_cache.t val venv_add_cache : t -> Omake_cache.t -> t (* * Add values to environment. *) val venv_chdir : t -> Lm_location.t -> string -> t val venv_chdir_dir : t -> Lm_location.t -> Omake_node.Dir.t -> t val venv_chdir_tmp : t -> Omake_node.Dir.t -> t val venv_add_dir : t -> unit val venv_directories : t -> t Omake_node.DirTable.t val venv_add_explicit_dir : t -> Omake_node.Dir.t -> unit val venv_remove_explicit_dir : t -> Omake_node.Dir.t -> unit val venv_add_file : t -> Omake_node.Node.t -> t val venv_intern : t -> Omake_node_sig.phony_ok -> string -> Omake_node.Node.t val venv_intern_cd : t -> Omake_node_sig.phony_ok -> Omake_node.Dir.t -> string -> Omake_node.Node.t val venv_intern_cd_1 : t -> Omake_node_sig.phony_ok -> Omake_node.Dir.t -> Omake_node.phony_name -> Omake_node.Node.t val venv_intern_cd_node_kind : t -> Omake_node_sig.phony_ok -> Omake_node.Dir.t -> Omake_node.phony_name -> Omake_node_sig.node_kind val venv_intern_dir : t -> string -> Omake_node.Dir.t val venv_intern_target : t -> Omake_node_sig.phony_ok -> Omake_value_type.target -> Omake_node.Node.t val venv_dirname : t -> Omake_node.Dir.t -> string val venv_nodename : t -> Omake_node.Node.t -> string val venv_mount : t -> Omake_node_sig.mount_option list -> Omake_node.Dir.t -> Omake_node.Dir.t -> t val venv_add_var : t -> Omake_ir.var_info -> Omake_value_type.t -> t val venv_add_phony : t -> Lm_location.t -> Omake_value_type.target list -> t val venv_add_args : t -> Omake_value_type.pos -> Lm_location.t -> Omake_value_type.env -> Omake_ir.param list -> Omake_value_type.t list -> Omake_value_type.keyword_param_value list -> Omake_value_type.keyword_value list -> t val venv_with_args : t -> Omake_value_type.pos -> Lm_location.t -> Omake_ir.param list -> Omake_value_type.t list -> Omake_value_type.keyword_param_value list -> Omake_value_type.keyword_value list -> t val venv_add_curry_args : t ->Omake_value_type.pos -> Lm_location.t -> Omake_value_type.env -> Omake_value_type.param_value list -> Omake_ir.param list -> Omake_value_type.t list -> Omake_value_type.keyword_param_value list -> Omake_value_type.keyword_value list -> Omake_value_type.keyword_value list -> t * Omake_value_type.t list * Omake_value_type.keyword_value list val venv_add_partial_args : t -> Omake_value_type.pos -> Lm_location.t -> Omake_value_type.env -> Omake_value_type.param_value list -> Omake_ir.param list -> Omake_value_type.t list -> Omake_value_type.keyword_param_value list -> Omake_value_type.keyword_value list -> Omake_value_type.keyword_value list -> partial_apply val venv_with_partial_args : t -> Omake_value_type.env -> Omake_value_type.param_value list -> t val venv_add_wild_match : t -> Omake_value_type.t -> t val venv_add_match_values : t -> Omake_value_type.t list -> t val venv_add_match_args : t -> string list -> t val venv_add_match : t -> string -> string list -> t val venv_explicit_target : t -> Omake_node.Node.t -> t val venv_explicit_find : t -> Omake_value_type.pos -> Omake_node.Node.t -> erule val venv_add_rule : t -> Omake_value_type.pos -> Lm_location.t -> Omake_value_type.rule_multiple -> (* multiple, scanner, etc *) Omake_value_type.target list -> (* targets *) Omake_value_type.target list -> (* patterns *) Omake_value_type.target Omake_value_type.source list -> (* effects *) Omake_value_type.target Omake_value_type.source list -> (* sources *) Omake_value_type.target Omake_value_type.source list -> (* scanners *) Omake_value_type.t list -> (* additional values the Omake_value_type.target depends on *) Omake_value_type.command list -> (* commands *) t * Omake_node.Node.t list val venv_add_memo_rule : t -> Omake_value_type.pos -> Lm_location.t -> bool -> (* multiple *) bool -> (* static flag *) Omake_value_type.t -> (* key *) Omake_ir.var_info list -> (* variables to be defined *) Omake_value_type.target Omake_value_type.source list -> (* sources *) Omake_value_type.t list -> (* additional values the Omake_value_type.target depends on *) Omake_ir.exp -> (* commands *) t val venv_set_static_info : t -> Omake_value_type.t -> static_info -> unit val venv_find_static_info : t -> Omake_value_type.pos -> Omake_value_type.t -> static_info (* * System environment. *) val venv_environment : t -> string Lm_symbol.SymbolTable.t val venv_setenv : t -> Omake_ir.var -> string -> t val venv_getenv : t -> Omake_ir.var -> string val venv_unsetenv : t -> Omake_ir.var -> t val venv_defined_env : t -> Omake_ir.var -> bool (* * Handle options. *) val venv_options : t -> Omake_options.t val venv_with_options : t -> Omake_options.t -> t val venv_set_options : t -> Lm_location.t -> Omake_value_type.pos -> string list -> t (* * Values represented with handles. *) val venv_add_environment : t -> Omake_value_type.handle_env val venv_find_environment : t -> Omake_value_type.pos -> Omake_value_type.handle_env -> t (* * Find values. *) val venv_dir : t -> Omake_node.Dir.t val venv_defined : t -> Omake_ir.var_info -> bool (* val venv_defined_field : t -> Omake_value_type.obj -> Omake_ir.var -> bool *) val venv_get_var : t -> Omake_value_type.pos -> Omake_ir.var_info -> Omake_value_type.t val venv_find_var : t -> Omake_value_type.pos -> Lm_location.t -> Omake_ir.var_info -> Omake_value_type.t val venv_find_var_exn : t -> Omake_ir.var_info -> Omake_value_type.t val venv_find_object_or_empty : t -> Omake_ir.var_info -> Omake_value_type.obj (* * Static environments. *) val venv_empty_env : Omake_value_type.env val venv_get_env : t -> Omake_value_type.env val venv_with_env : t -> Omake_value_type.env -> t (* * Static values. *) val venv_find_static_object : t -> Omake_node.Node.t -> Lm_symbol.t -> Omake_value_type.obj val venv_add_static_object : t -> Omake_node.Node.t -> Lm_symbol.t -> Omake_value_type.obj -> unit val venv_include_static_object : t -> Omake_value_type.obj -> t val venv_save_static_values : t -> unit (* * Primitive functions. *) type prim_fun_data = t -> Omake_value_type.pos -> Lm_location.t -> Omake_value_type.t list -> Omake_value_type.keyword_value list -> t * Omake_value_type.t val venv_add_prim_fun : t -> Omake_ir.var -> prim_fun_data -> Omake_value_type.prim_fun val venv_apply_prim_fun : Omake_value_type.prim_fun -> prim_fun_data (* * Channels. *) val venv_stdin : Omake_value_type.prim_channel val venv_stdout : Omake_value_type.prim_channel val venv_stderr : Omake_value_type.prim_channel val venv_add_channel : t -> Lm_channel.t -> Omake_value_type.prim_channel val venv_close_channel : t -> Omake_value_type.pos -> Omake_value_type.prim_channel -> unit val venv_find_channel : t -> Omake_value_type.pos -> Omake_value_type.prim_channel -> Lm_channel.t val venv_find_channel_by_channel : t -> Omake_value_type.pos -> Lm_channel.t -> Omake_value_type.prim_channel val venv_find_channel_by_id : t -> Omake_value_type.pos -> int -> Omake_value_type.prim_channel val venv_add_formatter_channel : t -> Format.formatter -> Omake_value_type.prim_channel (* * Objects. *) val venv_empty_object : Omake_value_type.obj val venv_this : t -> Omake_value_type.obj val venv_current_object : t -> Lm_symbol.t list -> Omake_value_type.obj val venv_define_object : t -> t val venv_with_object : t -> Omake_value_type.obj -> t val venv_include_object : t -> Omake_value_type.obj -> t val venv_flatten_object : t -> Omake_value_type.obj -> t val venv_find_super_field : t -> Omake_value_type.pos -> Lm_location.t -> Lm_symbol.t -> Lm_symbol.t -> Omake_value_type.t (* ZZZ: this doesn't exist in 0.9.9 *) val venv_current_objects : t -> Omake_value_type.pos -> Omake_ir.var_info -> Omake_value_type.t list val venv_add_class : Omake_value_type.obj -> Lm_symbol.t -> Omake_value_type.obj val venv_instanceof : Omake_value_type.obj -> Lm_symbol.t -> bool val venv_find_field_path_exn : t -> Omake_value_type.path -> Omake_value_type.obj -> Omake_value_type.pos -> Omake_ir.var -> Omake_value_type.path * Omake_value_type.t val venv_find_field_path : t -> Omake_value_type.path -> Omake_value_type.obj -> Omake_value_type.pos -> Omake_ir.var -> Omake_value_type.path * Omake_value_type.t val venv_find_field_exn : t -> Omake_value_type.obj -> Omake_value_type.pos -> Omake_ir.var -> Omake_value_type.t val venv_find_field : t -> Omake_value_type.obj -> Omake_value_type.pos -> Omake_ir.var -> Omake_value_type.t val venv_add_field : t -> Omake_value_type.obj -> Omake_value_type.pos -> Omake_ir.var -> Omake_value_type.t -> t * Omake_value_type.obj val venv_defined_field : t -> Omake_value_type.obj -> Omake_ir.var -> bool val venv_object_length : Omake_value_type.obj -> int (* Internal hacks when we don't care about checking *) val venv_add_field_internal : Omake_value_type.obj -> Omake_ir.var -> Omake_value_type.t -> Omake_value_type.obj val venv_find_field_internal : Omake_value_type.obj -> Omake_value_type.pos -> Omake_ir.var -> Omake_value_type.t val venv_find_field_internal_exn : Omake_value_type.obj -> Omake_ir.var -> Omake_value_type.t val venv_defined_field_internal : Omake_value_type.obj -> Omake_ir.var -> bool val venv_object_fold_internal : ('a -> Omake_ir.var -> Omake_value_type.t -> 'a) -> 'a -> Omake_value_type.obj -> 'a val venv_add_included_file : t -> Omake_node.Node.t -> t val venv_is_included_file : t -> Omake_node.Node.t -> bool val venv_find_ir_file_exn : t -> Omake_node.Node.t -> Omake_ir.t val venv_add_ir_file : t -> Omake_node.Node.t -> Omake_ir.t -> unit val venv_find_object_file_exn : t -> Omake_node.Node.t -> Omake_value_type.obj val venv_add_object_file : t -> Omake_node.Node.t -> Omake_value_type.obj -> unit (* * Maps. *) val venv_map_empty : Omake_value_type.map val venv_map_add : Omake_value_type.map -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t -> Omake_value_type.map val venv_map_remove : Omake_value_type.map -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.map val venv_map_find : Omake_value_type.map -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t val venv_map_mem : Omake_value_type.map -> Omake_value_type.pos -> Omake_value_type.t -> bool val venv_map_iter : (Omake_value_type.t -> Omake_value_type.t -> unit) -> Omake_value_type.map -> unit val venv_map_map : (Omake_value_type.t -> Omake_value_type.t -> Omake_value_type.t) -> Omake_value_type.map -> Omake_value_type.map val venv_map_fold : ('a -> Omake_value_type.t -> Omake_value_type.t -> 'a) -> 'a -> Omake_value_type.map -> 'a val venv_map_length : Omake_value_type.map -> int (* * Get a list of all the files that were read. *) val venv_files : t -> Omake_node.NodeSet.t (* * Get the explicit rules. *) val venv_explicit_exists : t -> Omake_node.Node.t -> bool val venv_explicit_rules : t -> erule_info (* * Find all the implicit rules and dependencies. * (static_deps, lock_deps, scanner_deps, value_deps) *) val venv_find_implicit_deps : t -> Omake_node.Node.t -> Omake_node.NodeSet.t * Omake_node.NodeSet.t * Omake_node.NodeSet.t * Omake_value_type.t list val venv_find_implicit_rules : t -> Omake_node.Node.t -> erule list (* * Ordering. *) val venv_add_orders : t -> Lm_location.t -> Omake_value_type.target list -> t val venv_is_order : t -> string -> bool val venv_add_ordering_rule : t -> Omake_value_type.pos -> Lm_location.t -> Omake_ir.var -> Omake_value_type.target -> Omake_value_type.target list -> t val venv_get_ordering_info : t -> Omake_ir.var -> ordering_info val venv_get_ordering_deps : t -> ordering_info -> Omake_node.NodeSet.t -> Omake_node.NodeSet.t (* * Update the environment with a result. *) val add_exports : t -> t -> Omake_value_type.pos -> Omake_ir.export -> t val add_path_exports : t -> t -> t -> Omake_value_type.pos -> Omake_value_type.path -> Omake_ir.export -> t val hoist_path : t -> Omake_value_type.path -> Omake_value_type.obj -> t val hoist_this : t -> t -> Omake_value_type.path -> t (* * Cached buildable flags. *) val venv_lookup_target_dir : t -> Omake_node.Dir.t -> target_dir val venv_find_target_is_buildable_exn : t -> target_dir -> string -> Omake_node_sig.node_kind -> bool val venv_find_target_is_buildable_multi : t -> string -> Omake_node_sig.node_kind -> target_dir -> bool val venv_find_target_is_buildable_proper_exn : t -> target_dir -> string -> Omake_node_sig.node_kind -> bool val venv_add_target_is_buildable : t -> target_dir -> string -> Omake_node_sig.node_kind -> bool -> unit val venv_add_target_is_buildable_proper : t -> target_dir -> string -> Omake_node_sig.node_kind -> bool -> unit val venv_add_target_is_buildable_multi : t -> string -> Omake_node_sig.node_kind -> target_dir list -> target_dir list -> unit (* * Printing. *) val pp_print_tok : tok Lm_printf.t val pp_print_string_pipe : string_pipe Lm_printf.t val pp_print_string_command_inst : string_command_inst Lm_printf.t val pp_print_string_command_line : string_command_line Lm_printf.t val pp_print_string_command_lines : string_command_line list Lm_printf.t val pp_print_arg_pipe : arg_pipe Lm_printf.t val pp_print_arg_command_inst : arg_command_inst Lm_printf.t val pp_print_arg_command_line : arg_command_line Lm_printf.t val pp_print_arg_command_lines : arg_command_line list Lm_printf.t (************************************************************************ * For squashing (producing digests). *) val squash_prim_fun : Omake_value_type.prim_fun -> Omake_ir.var val squash_object : Omake_value_type.obj -> Omake_value_type.t Lm_symbol.SymbolTable.t (* * General exception includes debugging info. *) exception Break of Lm_location.t * t (* * For debugging. *) val pp_print_explicit_rules : t Lm_printf.t val pp_print_rule : erule Lm_printf.t (* * Static values. *) val debug_db : bool ref (* * Static loading. *) module type StaticSig = sig type in_handle type out_handle (* * Open a file. The Omake_node.Node.t is the name of the _source_ file, * not the .omc file. We'll figure out where the .omc file * goes on our own. Raises Not_found if the source file * can't be found. * The implementation will make sure all the locking/unlocking is done properly. *) val read : t -> Omake_node.Node.t -> (in_handle -> 'a) -> 'a val rewrite : in_handle -> (out_handle -> 'a) -> 'a (* * Fetch the two kinds of entries. *) val find_ir : in_handle -> Omake_ir.t val find_object : in_handle -> Omake_value_type.obj val get_ir : out_handle -> Omake_ir.t val get_object : out_handle -> Omake_value_type.obj (* * Add the two kinds of entries. *) val add_ir : out_handle -> Omake_ir.t -> unit val add_object : out_handle -> Omake_value_type.obj -> unit end module Static : StaticSig;; omake-0.10.3/src/env/omake_ir_ast.mli0000644000175000017500000000231313177364666016054 0ustar gerdgerd (* * Parsing environments. *) type penv (* * Parse a variable declaration. *) val parse_declaration : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_ir.var list -> Omake_ir.method_name (* * Environment for parsing AST files. *) type senv_open_file = string -> Omake_value_type.pos -> Lm_location.t -> Omake_node.Node.t * Omake_ir.senv (* * Internal function for converting string expressions. *) val build_string : penv -> Omake_ast.exp -> Omake_value_type.pos -> penv * Omake_ir.string_exp (* * Create a parsing environment for the given file. * penv_create (file, pervasives_id) *) val penv_create : senv_open_file -> Omake_env.t -> Omake_node.Node.t -> penv val penv_class_names : penv -> Lm_symbol.t list * Omake_ir.senv val penv_of_vars : senv_open_file -> Omake_env.t -> Omake_node.Node.t -> Omake_ir.senv -> penv (* * Compile an AST program. *) val compile_string : penv -> Omake_ast.exp -> Omake_value_type.pos -> penv * Omake_ir.string_exp val compile_exp : penv -> Omake_ast.exp -> penv * Omake_ir.t val compile_exp_list : penv -> Omake_ast.exp list -> penv * Omake_ir.t val compile_prog : penv -> Omake_ast.prog -> penv * Omake_ir.t omake-0.10.3/src/env/omake_ast_parse.input0000644000175000017500000010172513177364666017141 0ustar gerdgerd %{ include Omake_pos.Make (struct let name = "Omake_parse" end) (* * Define flags. *) let define_flag (s, loc) = match s with | "=" -> Omake_ast.DefineNormal | "+=" -> DefineAppend | _ -> raise (Omake_value_type.OmakeException (loc_exp_pos loc, StringStringError ("undefined assignment operator", s))) (* * Convert arguments to parameters. *) let key_of_id s = Lm_symbol.add (String.sub s 1 (String.length s - 1)) let parse_id_param s loc = match s.[0] with '?' -> Omake_ast.OptionalParam (key_of_id s, NullExp loc, loc) | '~' -> RequiredParam (key_of_id s, loc) | _ -> NormalParam (Lm_symbol.add s, loc) let param_of_arg arg = match arg with | Omake_ast.IdArg (s, _, loc) -> parse_id_param s loc | NormalArg (KeyArg (v, e)) -> OptionalParam (v, e, Omake_ast_util.loc_of_exp e) | NormalArg (ExpArg e) -> raise (Omake_value_type.OmakeException (loc_exp_pos (Omake_ast_util.loc_of_exp e), StringAstError ("illegal function parameter", e))) | NormalArg (ArrowArg (_, e)) -> raise (Omake_value_type.OmakeException (loc_exp_pos (Omake_ast_util.loc_of_exp e), StringAstError ("illegal function argument", e))) let get_fun_params args = List.map param_of_arg args (* * Remove the IdArg. *) let arg_of_parse_arg = function | Omake_ast.IdArg (s, w, loc1) -> let id = Omake_ast.StringIdExp (s, loc1) in let e = match w with Some (w, loc2) -> Omake_ast.SequenceExp ([id; StringWhiteExp (w, loc2)], loc1) | None -> id in Omake_ast.ExpArg e | NormalArg arg -> arg let args_of_parse_args = List.map arg_of_parse_arg (* * Utilities. *) let rec simplify e = match e with | Omake_ast.SequenceExp ([e], _) -> simplify e | _ -> e let sequence_exp l loc = match l with | [e] -> e | _ -> Omake_ast.SequenceExp (l, loc) (* * Intern the method name. *) let method_id_intern idl = List.map Lm_symbol.add idl (* * Get a string from a method name. *) let method_id_string idl = let buf = Buffer.create 32 in let rec collect idl = match idl with [id] -> Buffer.add_string buf id | id :: idl -> Buffer.add_string buf id; Buffer.add_char buf '.'; collect idl | [] -> () in collect idl; Buffer.contents buf let rec method_id_rev_sequence loc items idl = match idl with [id] -> (Omake_ast.StringIdExp (id, loc)) :: items | id :: idl -> let items = Omake_ast.StringOpExp (".", loc) :: StringIdExp (id, loc) :: items in method_id_rev_sequence loc items idl | [] -> items let method_id_sequence loc idl = List.rev (method_id_rev_sequence loc [] idl) let method_id_string_exp idl loc = Omake_ast.SequenceExp (method_id_sequence loc idl, loc) let method_id_prefix_string_exp idl loc = let idl = List.rev (method_id_rev_sequence loc [StringOpExp (".", loc)] idl) in Omake_ast.SequenceExp (idl, loc) let var_quote (strategy, s, loc) = Omake_ast.KeyExp (strategy, s, loc), loc (* * Convert to a body flag and text. *) let get_optcolon_text opt loc = match opt with None -> Omake_ast.OptBody, Omake_ast.NullExp loc | Some (body, arg) -> body, arg (* * A 3-place rule. *) let rule3 multiple (target, loc1) _ pattern source loc2 body = let loc = Lm_location.union_loc loc1 loc2 in match pattern with Some (pattern, _) -> Omake_ast.RuleExp (multiple, target, pattern, source, body, loc) | None -> RuleExp (multiple, target, NullExp loc2, source, body, loc) let rule2 multiple target ploc source loc2 body = rule3 multiple target ploc None source loc2 body %} /* * Terminators */ %token TokEof %token TokEol /* * Whitespace. */ %token TokWhite /* * Characters. */ %token TokLeftParen %token TokRightParen %token TokArrow %token TokComma %token TokColon %token TokDoubleColon %token TokNamedColon %token TokDollar %token TokEq %token TokArray %token TokDot /* * Words. */ %token TokId %token TokKey %token TokKeyword %token TokCatch %token TokClass %token TokOp %token TokInt %token TokFloat %token TokString %token TokBeginQuote %token TokEndQuote %token TokBeginQuoteString %token TokEndQuoteString %token TokStringQuote %token TokVar %token TokVarQuote /* * A complete program. */ %start deps %type <(Omake_ast.exp * Omake_ast.exp * Lm_location.t) list> deps %start shell %start string %type shell %type string %% /* * A string is just some text. */ string: TokEof { raise End_of_file } | text TokEol TokEof { NoBody, sequence_exp $1 $2 } ; /* * Commands in a shell. * Bodies are usually not allowed. */ shell: TokEof { raise End_of_file } | shell_line TokEof { $1 } ; shell_line: /* Blank lines */ opt_white TokEol { NoBody, sequence_exp [] $2 } /* Builtin functions */ | TokKeyword TokWhite keyword_text_optcolon TokEol { let id, loc1 = $1 in let body, arg = get_optcolon_text $3 $4 in let loc = Lm_location.union_loc loc1 $4 in body, CommandExp (Lm_symbol.add id, arg, [], loc) } | TokKeyword opt_literal_colon TokEol { let id, loc1 = $1 in let body = $2 in let loc = Lm_location.union_loc loc1 $3 in let arg = Omake_ast.NullExp loc in body, CommandExp (Lm_symbol.add id, arg, [], loc) } /* Keyword applications */ | TokKeyword opt_white TokLeftParen opt_args TokRightParen opt_colon TokEol { let id, loc1 = $1 in let body = $6 in let loc = Lm_location.union_loc loc1 $7 in let args = args_of_parse_args $4 in let e = Omake_ast.ApplyExp (CommandApply, Lm_symbol.add id, args, loc) in body, e } /* Catch expression is special */ | TokCatch opt_white TokId opt_white TokLeftParen opt_white TokId opt_white TokRightParen opt_colon TokEol { let _, loc1 = $1 in let loc = Lm_location.union_loc loc1 $11 in let name, _ = $3 in let v, _ = $7 in $10, CatchExp (Lm_symbol.add name, Lm_symbol.add v, [], loc) } /* Class expression is special */ | TokClass opt_id_list TokEol { let _, loc1 = $1 in let loc = Lm_location.union_loc loc1 $3 in NoBody, ClassExp (List.map Lm_symbol.add $2, loc) } /* Variable definition with a body */ | method_id_opt_white TokEq opt_white TokEol { let id, loc1 = $1 in let loc2 = $4 in let id = method_id_intern id in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag $2 in ColonBody, VarDefBodyExp (id, DefineString, add_flag, [], loc) } /* Object definition with a body */ | method_id_prefix_opt_white TokEq opt_white TokEol { let id, loc1 = $1 in let loc2 = $4 in let id = method_id_intern id in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag $2 in ColonBody, ObjectDefExp (id, add_flag, [], loc) } /* Variable definition on one line */ | method_id_opt_white TokEq opt_white text_nonempty TokEol { let id, loc1 = $1 in let loc2 = $5 in let e = simplify $4 in let id = method_id_intern id in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag $2 in NoBody, VarDefExp (id, DefineString, add_flag, e, loc) } /* Key definition with a body */ | var_quote_opt_white TokEq opt_white TokEol { let _, id, loc1 = $1 in let loc2 = $4 in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag $2 in ColonBody, KeyDefBodyExp (id, DefineString, add_flag, [], loc) } /* Key definition on one line */ | var_quote_opt_white TokEq opt_white text_nonempty TokEol { let _, id, loc1 = $1 in let loc2 = $5 in let e = simplify $4 in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag $2 in NoBody, KeyDefExp (id, DefineString, add_flag, e, loc) } /* Array definition */ | method_id_opt_white TokArray opt_white TokEq opt_white TokEol { let id, loc1 = $1 in let loc2 = $6 in let id = method_id_intern id in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag $4 in ArrayBody, VarDefBodyExp (id, DefineArray, add_flag, [], loc) } /* Array definition on one line */ | method_id_opt_white TokArray opt_white TokEq opt_white text_nonempty TokEol { let id, loc1 = $1 in let loc2 = $7 in let id = method_id_intern id in let loc = Lm_location.union_loc loc1 loc2 in let add_flag = define_flag $4 in NoBody, VarDefExp (id, DefineArray, add_flag, $6, loc) } /* Applications that use parens may also have a body */ | method_id_opt_white TokLeftParen opt_args TokRightParen opt_colon TokEol { let id, loc1 = $1 in let body = $5 in let loc = Lm_location.union_loc loc1 $6 in let args = args_of_parse_args $3 in let e = match id with [id] -> Omake_ast.ApplyExp (CommandApply, Lm_symbol.add id, args, loc) | _ -> MethodApplyExp (CommandApply, method_id_intern id, args, loc) in body, e } /* Applications with all binding vars */ | method_id_opt_white TokLeftParen opt_args TokRightParen opt_colon TokArrow opt_white TokEol { let id, loc1 = $1 in let body = $5 in let loc = Lm_location.union_loc loc1 $8 in let params = get_fun_params $3 in let arg = Omake_ast.ArrowArg (params, StringOpExp ("...", loc)) in let e = match id with [id] -> Omake_ast.ApplyExp (CommandApply, Lm_symbol.add id, [arg], loc) | _ -> MethodApplyExp (CommandApply, method_id_intern id, [arg], loc) in body, e } /* Function definition */ | method_id_opt_white TokLeftParen opt_args TokRightParen opt_white TokEq opt_white TokEol { let id, loc1 = $1 in let id = method_id_intern id in let params = get_fun_params $3 in let loc = Lm_location.union_loc loc1 $8 in ColonBody, FunDefExp (id, params, [], loc) } /* 2-place rule definition that starts with a name */ | other_id_target TokColon source TokEol { ColonBody, rule2 false $1 $2 $3 $4 [] } | other_id_target TokColon target TokColon source TokEol { ColonBody, rule3 false $1 $2 $3 $5 $6 [] } | other_target TokColon source TokEol { ColonBody, rule2 false $1 $2 $3 $4 [] } | other_target TokDoubleColon source TokEol { ColonBody, rule2 true $1 $2 $3 $4 [] } | other_target TokColon target TokColon source TokEol { ColonBody, rule3 false $1 $2 $3 $5 $6 [] } | other_target TokDoubleColon target TokColon source TokEol { ColonBody, rule3 true $1 $2 $3 $5 $6 [] } /* * Super section. * We have to be careful about distinguishing rules from * super calls. */ | method_id_opt_white TokDoubleColon opt_white source_nonapply TokEol { let idl, loc = $1 in let e = method_id_string_exp idl loc in ColonBody, rule2 true (e, loc) $2 $4 $5 [] } | method_id_prefix_opt_white TokDoubleColon source TokEol { let idl, loc = $1 in let e = method_id_prefix_string_exp idl loc in ColonBody, rule2 true (e, loc) $2 $3 $4 [] } | method_id_opt_white TokDoubleColon opt_white method_id_opt_white TokLeftParen opt_args TokRightParen opt_colon TokEol { let super, loc1 = $1 in let name, _ = $4 in let body = $8 in let loc = Lm_location.union_loc loc1 $9 in let args = args_of_parse_args $6 in let e = match super, name with [super], [name] -> Omake_ast.SuperApplyExp (CommandApply, Lm_symbol.add super, Lm_symbol.add name, args, loc) | _, [_] -> raise (Omake_value_type.OmakeException (loc_exp_pos loc, StringStringError ("illegal super class", method_id_string super))) | _ -> raise (Omake_value_type.OmakeException (loc_exp_pos loc, StringStringError ("illegal field name", method_id_string name))) in body, e } /* Anything else is a command to run */ | other_id_target TokEol { let e, loc = $1 in NoBody, ShellExp (e, loc) } | other_target TokEol { let e, loc = $1 in NoBody, ShellExp (e, loc) } ; /* * Dependencies only. */ deps: rev_deps TokEof { List.rev $1 } ; rev_deps: /* empty */ { [] } | rev_deps dep { $2 :: $1 } | rev_deps TokEol { $1 } ; dep: /* 2-place rule dependency */ target TokColon target TokEol { let _, loc2 = $2 in let target, loc1 = match $1 with Some (e, loc1) -> e, loc1 | None -> NullExp loc2, loc2 in let source = match $3 with Some (e, _) -> e | None -> NullExp loc2 in let loc = Lm_location.union_loc loc1 $4 in target, source, loc } ; /* * A variable lookup. */ apply: TokDollar opt_white TokLeftParen opt_white method_name opt_apply_args TokRightParen { let _, strategy, loc1 = $1 in let _, loc2 = $7 in let idl, _ = $5 in let args = args_of_parse_args $6 in let loc = Lm_location.union_loc loc1 loc2 in match idl with [id] -> Omake_ast.ApplyExp (strategy, Lm_symbol.add id, args, loc), loc | _ -> MethodApplyExp (strategy, method_id_intern idl, args, loc), loc } | TokDollar opt_white TokLeftParen opt_white id TokDoubleColon id opt_apply_args TokRightParen { let _, strategy, loc1 = $1 in let _, loc2 = $9 in let super, _ = $5 in let v, _ = $7 in let args = args_of_parse_args $8 in let loc = Lm_location.union_loc loc1 loc2 in SuperApplyExp (strategy, Lm_symbol.add super, Lm_symbol.add v, args, loc), loc } | TokVar { let strategy, id, loc = $1 in ApplyExp (strategy, Lm_symbol.add id, [], loc), loc } | TokBeginQuote rev_text TokEndQuote { let id1, loc1 = $1 in let id2, loc2 = $3 in let loc = Lm_location.union_loc loc1 loc2 in let el = Omake_ast.StringOtherExp (id1, loc1) :: List.rev_append $2 [ Omake_ast.StringOtherExp (id2, loc2)] in QuoteExp (el, loc), loc } | TokBeginQuoteString rev_text TokEndQuoteString { let id, loc1 = $1 in let _, loc2 = $3 in let loc = Lm_location.union_loc loc1 loc2 in QuoteStringExp (id.[0], List.rev $2, loc), loc } | TokStringQuote { let s, loc = $1 in QuoteExp ([StringOtherExp (s, loc)], loc), loc } ; /* * A quoted variable. */ var_quote_opt_white: var_quote { $1 } | var_quote_white { let strategy, id, _, loc = $1 in strategy, id, loc } ; var_quote_white: var_quote TokWhite { let strategy, id, loc = $1 in let s, _ = $2 in strategy, id, s, loc } ; var_quote: TokVarQuote { $1 } ; /* * Variable lookup. */ quote_opt_white: var_quote_opt_white { var_quote $1 } ; quote_white: var_quote_white { let strategy, id, s, loc = $1 in let e, _ = var_quote (strategy, id, loc) in e, s, loc } ; quote: var_quote { var_quote $1 } ; /* * Names separated by dots. */ method_name: rev_method_name { let idl, loc = $1 in List.rev idl, loc } ; rev_method_name: id { let id, loc = $1 in [id], loc } | rev_method_name TokDot id { let idl, loc1 = $1 in let id, loc2 = $3 in id :: idl, Lm_location.union_loc loc1 loc2 } ; id: TokId { $1 } | TokKeyword { $1 } | TokCatch { $1 } | TokClass { $1 } ; opt_id_list: /* empty */ { [] } | opt_id_list white { $1 } | opt_id_list id { let id, _ = $2 in id :: $1 } ; /* * A target after identifier text. * It may not begin with equals, left-paren, or . * and it may not contains colons. */ other_id_target: method_id_opt_white { let idl, loc = $1 in method_id_string_exp idl loc, loc } | method_id_prefix_opt_white { let idl, loc = $1 in method_id_prefix_string_exp idl loc, loc } | quote_opt_white { $1 } ; method_id_opt_white: rev_method_id { let id, loc = $1 in List.rev id, loc } | rev_method_id_white { let id, _, loc = $1 in List.rev id, loc } ; method_id_prefix_opt_white: rev_method_id_prefix { let id, loc = $1 in List.rev id, loc } | rev_method_id_prefix_white { let id, _, loc = $1 in List.rev id, loc } ; rev_method_id_white: rev_method_id TokWhite { let id, loc1 = $1 in let s, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in id, s, loc } ; rev_method_id_prefix_white: rev_method_id_prefix TokWhite { let id, loc1 = $1 in let s, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in id, s, loc } ; rev_method_id: TokId { let id, loc = $1 in [id], loc } | rev_method_id_prefix id { let idl, loc1 = $1 in let id, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in id :: idl, loc } ; rev_method_id_prefix: rev_method_id TokDot { let idl, loc1 = $1 in let _, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in idl, loc } | TokKeyword TokDot { let id, loc1 = $1 in let _, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in [id], loc } | TokClass TokDot { let id, loc1 = $1 in let _, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in [id], loc } | TokCatch TokDot { let id, loc1 = $1 in let _, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in [id], loc } ; /* * The other_target collects all the other stuff that * is not a valid command prefix, but it does not allow colons. * Don't worry about catching all the other cases--here * are the things we should not match: * TokKeyword anything * TokCatch anything * method_id_opt_white TokEq * method_id_prefix_opt_white TokEq * method_id_opt_white TokArray * method_id_opt_white TokLeftParen * * So here are the sequences that put us into other mode: * 1. [^ TokKeyword TokCatch TokId TokColon] * 2. method_id [^ TokEq TokArray TokLeftParen TokDot TokWhite TokColon] * 3. method_id_white [^ TokEq TokArray TokLeftParen TokColon] * 4. method_id_prefix [^ TokEq TokWhite TokColon] * 5. method_id_prefix_white [^ TokEq TokColon] * Then collect anything except TokColon */ other_target: rev_other_target { let l, loc = $1 in sequence_exp (List.rev l) loc, loc } ; rev_other_target: other_start { let e, loc = $1 in [e], loc } | rev_method_id other_method_id { let idl, loc1 = $1 in let e, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in let el = [e; method_id_string_exp (List.rev idl) loc1] in el, loc } | rev_method_id_white other_method_id_white { let idl, s, loc1 = $1 in let e, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in let el = [e; Omake_ast.StringWhiteExp (s, loc1); method_id_string_exp (List.rev idl) loc1] in el, loc } | rev_method_id_prefix other_method_id_prefix { let idl, loc1 = $1 in let e, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in let el = [e; method_id_prefix_string_exp (List.rev idl) loc1] in el, loc } | rev_method_id_prefix_white other_method_id_prefix_white { let idl, s, loc1 = $1 in let e, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in let el = [e; Omake_ast.StringWhiteExp (s, loc1); method_id_prefix_string_exp (List.rev idl) loc1] in el, loc } | quote other_quote_id { let id, loc1 = $1 in let e, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in let el = [id; e] in el, loc } | quote_white other_quote_id_white { let id, s, loc1 = $1 in let e, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in let el = [id; StringWhiteExp (s, loc1); e] in el, loc } | rev_other_target target_next { let el, loc1 = $1 in let e, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in e :: el, loc } ; /************************************************************************ * Source arguments allow named colons. */ source: target { match $1 with Some (e, _) -> Lm_symbol.SymbolTable.add Lm_symbol.SymbolTable.empty Omake_symbol.normal_sym e | None -> Lm_symbol.SymbolTable.empty } | source TokNamedColon target { let table = $1 in let name, _ = $2 in match $3 with Some (e, _) -> Lm_symbol.SymbolTable.add table (Lm_symbol.add name) e | None -> table } ; /* * This source cannot look like an application. */ source_nonapply: source_target { match $1 with Some (e, _) -> Lm_symbol.SymbolTable.add Lm_symbol.SymbolTable.empty Omake_symbol.normal_sym e | None -> Lm_symbol.SymbolTable.empty } | source_nonapply TokNamedColon target { let table = $1 in let name, _ = $2 in match $3 with Some (e, _) -> Lm_symbol.SymbolTable.add table (Lm_symbol.add name) e | None -> table } ; source_target: /* empty */ { None } | other_id_target { Some $1 } | other_target { Some $1 } ; /************************************************************************ * Sequence sections. */ /* * text: [^ TokEol]* * text_next: [^ TokEol] * Leading whitespace is not stripped. */ text: rev_text { List.rev $1 } ; rev_text: /* empty */ { [] } | rev_text text_next { let e, _ = $2 in e :: $1 } ; /* * target: [^ TokEol TokColon TokNamedColon]* * Leading whitespace is stripped: * target_start: [^ TokEol TokColon TokNamedColon TokWhite] * target_next: [^ TokEol TokColon TokNamedColon] */ target: opt_white { None } | opt_white rev_target { let l, loc = $2 in Some (sequence_exp (List.rev l) loc, loc) } ; rev_target: target_start { let e, loc = $1 in [e], loc } | rev_target target_next { let l, loc1 = $1 in let e, loc2 = $2 in e :: l, Lm_location.union_loc loc1 loc2 } ; /* * text_optcolon: text_colon | text_noncolon * text_colon: [^ TokEol]* TokColon * text_noncolon: ([^ TokEol]* [^ TokEol TokColon])? */ keyword_text_optcolon: /* empty */ { None } | rev_keyword_text { let code, _, el, loc = $1 in Some (code, sequence_exp (List.rev el) loc) } ; rev_keyword_text: keyword_target_start { let e, loc = $1 in OptBody, [], [e], loc } | colon { let e, loc = $1 in ColonBody, [e], [], loc } | rev_keyword_text white { let code, final, prefix, loc1 = $1 in let e, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in code, e :: final, prefix, loc } | rev_keyword_text target_start { let _, final, prefix, loc1 = $1 in let e, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in OptBody, [], e :: (final @ prefix), loc } | rev_keyword_text colon { let _, final, prefix, loc1 = $1 in let e, loc2 = $2 in let loc = Lm_location.union_loc loc1 loc2 in ColonBody, [e], final @ prefix, loc } ; /* * Strip trailing whitespace from nonempty text. */ text_nonempty: rev_text_nonempty { let l, loc = $1 in sequence_exp (List.rev l) loc } ; rev_text_nonempty: text_nonwhite { let e, loc = $1 in [e], loc } | rev_text_nonempty text_next { let l, loc1 = $1 in let e, loc2 = $2 in e :: l, Lm_location.union_loc loc1 loc2 } ; /* * arg: [^ TokEol TokComma TokArrow TokLeftParen TokRightParen]* * leading whitespace is stripped. */ opt_args: opt_white { [] } | args { $1 } ; opt_apply_args: opt_white { [] } | white args { $2 } ; args: rev_args { List.rev $1 } | rev_arrow_args { List.rev $1 } | rev_arrow_args TokComma rev_args { List.rev_append $1 (List.rev $3) } ; rev_arrow_args: arrow_arg { [$1] } | rev_arrow_args TokComma arrow_arg { $3 :: $1 } ; arrow_arg: rev_args TokArrow opt_white rev_any_arg { let el, loc2 = $4 in NormalArg (ArrowArg (get_fun_params (List.rev $1), sequence_exp (List.rev el) loc2)) } ; rev_args: arg { [$1] } | rev_args TokComma arg { $3 :: $1 } ; arg: opt_white arg_inner { $2 } ; arg_inner: rev_normal_arg { let el, loc = $1 in let e = sequence_exp (List.rev el) loc in NormalArg (ExpArg e) } | arg_id { let (id, _), w, loc = $1 in IdArg (id, w, loc) } | arg_key { let (id, _), w, loc = $1 in IdArg (id, w, loc) } | arg_key TokEq opt_white { let (id, _), _, loc1 = $1 in let key = key_of_id id in NormalArg (KeyArg (key, NullExp loc1)) } | arg_key TokEq opt_white rev_any_arg { let (id, _), _, _ = $1 in let key = key_of_id id in let el, loc2 = $4 in NormalArg (KeyArg (key, sequence_exp (List.rev el) loc2)) } ; arg_id: id opt_white { let id = $1 in let _, loc = id in id, $2, loc } ; arg_key: TokKey opt_white { let id = $1 in let _, loc = id in id, $2, loc } ; rev_any_arg: paren_arg_any_start { let e, loc = $1 in [e], loc } | rev_any_arg paren_arg_next { let l, loc1 = $1 in let e, loc2 = $2 in e :: l, Lm_location.union_loc loc1 loc2 } ; rev_normal_arg: arg_key paren_arg_next_noneq { let (id, loc0), w, loc1 = $1 in let id = Omake_ast.StringIdExp (id, loc0) in let e, loc2 = $2 in let el = match w with Some (w, loc0) -> [e; Omake_ast.StringWhiteExp (w, loc0); id] | None -> [e; id] in el, Lm_location.union_loc loc1 loc2 } | arg_id paren_arg_any_start { let (id, loc0), w, loc1 = $1 in let id = Omake_ast.StringIdExp (id, loc0) in let e, loc2 = $2 in let el = match w with Some (w, loc3) -> [e; StringWhiteExp (w, loc3); id] | None -> [e; id] in el, Lm_location.union_loc loc1 loc2 } | paren_arg_start { let e, loc = $1 in [e], loc } | rev_normal_arg paren_arg_next { let l, loc1 = $1 in let e, loc2 = $2 in e :: l, Lm_location.union_loc loc1 loc2 } ; paren_arg_any_start: arg_any_start { $1 } | paren_arg { $1 } ; paren_arg_next_noneq: arg_next_noneq { $1 } | paren_arg { $1 } ; paren_arg_start: arg_start { $1 } | paren_arg { $1 } ; paren_arg_next: arg_next { $1 } | paren_arg { $1 } ; paren_arg: TokLeftParen rev_paren_text TokRightParen { let s1, loc1 = $1 in let sl = $2 in let s3, loc3 = $3 in let loc = Lm_location.union_loc loc1 loc3 in let el = Omake_ast.StringOpExp (s1, loc1) :: (List.rev (Omake_ast.StringOpExp (s3, loc3) :: sl)) in SequenceExp (el, loc), loc } ; rev_paren_text: /* empty */ { [] } | rev_paren_text paren_next { let s, _ = $2 in s :: $1 } | rev_paren_text paren_arg { let s, _ = $2 in s :: $1 } ; /* * Generated section. */ %%GENERATED%% /* * Optional white space. */ opt_literal_colon: /* empty */ { OptBody } | colon opt_white { ColonBody } ; opt_colon: opt_white { OptBody } | opt_white colon opt_white { ColonBody } ; opt_white: /* empty */ { None } | TokWhite { Some $1 } ; omake-0.10.3/src/eval/0000755000175000017500000000000013177364666013054 5ustar gerdgerdomake-0.10.3/src/eval/OMakefile0000644000175000017500000000036613177364665014637 0ustar gerdgerdOCAMLINCLUDES[] += ../libmojave ../front ../util ../ast ../ir ../env ../exec FILES[] = omake_eval omake_value MakeOCamlLibrary(eval, $(FILES)) clean: $(CLEAN) # # Generate the Makefile # MakeMakefile() omake-0.10.3/src/eval/omake_eval.ml0000644000175000017500000023674113177364665015525 0ustar gerdgerd(* Predefined set of functions. *) include Omake_pos.Make (struct let name = "Omake_eval" end);; let debug_eval = Lm_debug.create_debug (**) { debug_name = "debug-eval"; debug_description = "Debug the evaluator"; debug_value = false } let print_ast = Lm_debug.create_debug (**) { debug_name = "print-ast"; debug_description = "Print the AST after parsing"; debug_value = false } let print_ir = Lm_debug.create_debug (**) { debug_name = "print-ir"; debug_description = "Print the IR after parsing"; debug_value = false } let print_rules = Lm_debug.create_debug (**) { debug_name = "print-rules"; debug_description = "Print the rules after evaluation"; debug_value = false } let print_files = Lm_debug.create_debug (**) { debug_name = "print-files"; debug_description = "Print the files as they are read"; debug_value = false } let bool_of_string s = match String.lowercase_ascii s with | "" | "0" | "no" | "nil" | "false" | "undefined" -> false | _ -> true (* * For now, use a bogu location for parameters. *) (* let param_loc = Lm_location.bogus_loc "Omake_eval.param" *) (* * Including files. *) (************************************************************************ * Utilities. *) let raise_uncaught_exception pos = function | Sys.Break | Omake_value_type.OmakeException _ | Omake_value_type.OmakeFatal _ | Omake_value_type.OmakeFatalErr _ | Omake_value_type.UncaughtException _ as exn -> raise exn | exn -> raise (Omake_value_type.UncaughtException (pos, exn)) (* * Add an optional quote. *) let buffer_add_quote buf = function Some c -> Buffer.add_char buf c | None -> () (* * The various forms of empty values. *) let rec is_empty_value ( v : Omake_value_type.t) = match v with | ValNone | ValWhite _ | ValString "" | ValData "" | ValQuote [] | ValArray [] | ValRules [] -> true | ValSequence vl -> List.for_all is_empty_value vl | ValObject obj -> (try is_empty_value (Omake_env.venv_find_field_internal_exn obj Omake_symbol.builtin_sym) with Not_found -> false) | ValInt _ | ValFloat _ | ValData _ | ValQuote _ | ValQuoteString _ | ValString _ | ValArray _ | ValMaybeApply _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValNode _ | ValDir _ | ValStringExp _ | ValBody _ | ValMap _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValDelayed _ | ValVar _ -> false (* * Check whether a value has an embedded array. *) let rec is_array_value (v : Omake_value_type.t) = match v with | ValArray _ -> true | ValSequence [v] | ValQuote [v] -> is_array_value v | ValObject obj -> (try match Omake_env.venv_find_field_internal_exn obj Omake_symbol.builtin_sym with ValArray _ -> true | _ -> false with Not_found -> false) | ValNone | ValInt _ | ValFloat _ | ValData _ | ValQuote _ | ValQuoteString _ | ValWhite _ | ValString _ | ValMaybeApply _ | ValSequence _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValNode _ | ValDir _ | ValStringExp _ | ValBody _ | ValMap _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValVar _ | ValDelayed _ -> false (* * Determine when an application is ready from its arity. *) type partial_arity = | FullArity of Omake_value_type.t list * Omake_value_type.t list | PartialArity of Omake_ir.arity * Omake_value_type.t list let rec concat_n_args args1 args2 n = if n = 0 then FullArity (List.rev args1, args2) else match args2 with arg :: args2 -> concat_n_args (arg :: args1) args2 (n - 1) | [] -> raise (Invalid_argument "concat_n_args") let arity_apply_args ( arity : Omake_ir.arity ) args1 args2 = let len = List.length args2 in match arity with | ArityRange (min, max) -> if len < min then let args = List.rev_append args2 args1 in PartialArity (ArityRange (min - len, max - len), args) else if len < max then let args = List.rev_append args1 args2 in FullArity (args, []) else concat_n_args args1 args2 max | ArityExact i -> if len < i then let args = List.rev_append args2 args1 in PartialArity ( ArityExact (i - len), args) else concat_n_args args1 args2 i | ArityNone -> FullArity ([], List.rev_append args1 args2) | ArityAny -> FullArity (List.rev_append args1 args2, []) (************************************************************************ * Compiling utilities. *) let postprocess_ir venv ( ir : Omake_ir.t) = let () = if Lm_debug.debug print_ir then Format.eprintf "@[IR1:@ %a@]@." Omake_ir_print.pp_print_exp ir.ir_exp in let ir = { ir with ir_exp = Omake_ir_semant.build_prog venv ir.ir_exp } in let () = if Lm_debug.debug print_ir then Format.eprintf "@[IR2:@ %a@]@." Omake_ir_print.pp_print_exp ir.ir_exp in ir (** Parse and evaluate a file. *) let rec parse_ir (venv : Omake_env.t) (scope : Omake_env.include_scope) (node : Omake_node.Node.t) : Omake_ir.t = let filename = Omake_node.Node.fullname node in let ast = Omake_ast_lex.parse_ast filename in let () = if Lm_debug.debug print_ast then Format.eprintf "@[AST (initial):@ %a@]@." Omake_ast_print.pp_print_prog ast in let ast = Omake_exp_lex.compile_prog ast in let () = if Lm_debug.debug print_ast then Format.eprintf "@[AST %a:@ %a@]@." Omake_node.pp_print_node node Omake_ast_print.pp_print_prog ast in let vars = Omake_env.venv_include_scope venv scope in let _senv, ir = Omake_ir_ast.compile_prog (Omake_ir_ast.penv_of_vars (open_ir venv) venv node vars) ast in postprocess_ir venv ir (* * When constructing a path, the relative filenames * should be auto-rehash. * * values : the path * dirname : the subdirectory to search (often ".") *) and path_of_values_select venv pos (values : Omake_value_type.t list) dirname = let rec collect groups auto_rehash items (values : Omake_value_type.t list) = match values with | v :: values -> let rehash_flag, dir = match v with | ValDir dir -> false, dir | ValNode _ -> let dir = Omake_env.venv_intern_dir venv (string_of_value venv pos v) in false, dir | _ -> let s = string_of_value venv pos v in let rehash_flag = not (Lm_filename_util.is_absolute s) in let dir = Omake_env.venv_intern_dir venv s in rehash_flag, dir in let dir = Omake_node.Dir.chdir dir dirname in let groups, items = if rehash_flag <> auto_rehash && items <> [] then (auto_rehash, List.rev items) :: groups, [dir] else groups, dir :: items in collect groups rehash_flag items values | [] -> if items <> [] then (auto_rehash, List.rev items) :: groups else groups in List.rev (collect [] false [] values) and path_of_values_rehash venv pos values dirname = let dir_of_value (v : Omake_value_type.t) = let dir = match v with | ValDir dir -> dir | _ -> Omake_env.venv_intern_dir venv (string_of_value venv pos v) in Omake_node.Dir.chdir dir dirname in [true, List.map dir_of_value values] and path_of_values venv pos values dirname = let auto_rehash = try bool_of_value venv pos (Omake_env.venv_find_var_exn venv Omake_var.auto_rehash_var) with Not_found -> false in let f = if auto_rehash then path_of_values_rehash else path_of_values_select in f venv pos values dirname (* * Open the file. * Get the IR and return the vars. *) and find_include_file venv pos loc filename = let pos = string_pos "find_include_file" pos in let cache = Omake_env.venv_cache venv in if not (Filename.is_relative filename) || not (Filename.is_implicit filename) then let fullname = filename ^ Omake_state.omake_file_suffix in let node1 = Omake_env.venv_intern venv PhonyProhibited fullname in if Omake_cache.exists cache node1 then node1 else let node2 = Omake_env.venv_intern venv PhonyProhibited filename in if Omake_cache.exists cache node2 then node2 else let print_error buf = Format.fprintf buf "@[include file not found, neither file exists:@ %a@ %a@]" (**) Omake_node.pp_print_node node1 Omake_node.pp_print_node node2 in raise (Omake_value_type.OmakeException (loc_pos loc pos, LazyError print_error)) else let dirname = Filename.dirname filename in let basename = Filename.basename filename in let fullname = basename ^ Omake_state.omake_file_suffix in let path = Omake_env.venv_find_var venv pos loc Omake_var.omakepath_var in let full_path = values_of_value venv pos path in let path = path_of_values venv pos full_path dirname in let cache = Omake_env.venv_cache venv in let listing = Omake_cache.ls_path cache path in try match Omake_cache.listing_find cache listing fullname with DirEntry dir -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringDirError ("is a directory", dir))) | NodeEntry node -> node with Not_found -> try match Omake_cache.listing_find cache listing basename with DirEntry dir -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringDirError ("is a directory", dir))) | NodeEntry node -> node with Not_found -> let print_error buf = Format.fprintf buf "@[include file %s not found in OMAKEPATH@ (@[OMAKEPATH[] =%a@])@]" (**) filename Omake_value_print.pp_print_value_list full_path in raise (Omake_value_type.OmakeException (loc_pos loc pos, LazyError print_error)) and open_ir venv filename pos loc = let pos = string_pos "open_ir" pos in let source = find_include_file venv pos loc filename in let ir : Omake_ir.t = compile_ir venv Omake_env.IncludePervasives pos loc source in if !print_ir then begin Format.eprintf "@[Vars: %a" Omake_node.pp_print_node source; Lm_symbol.SymbolTable.iter (fun v info -> Format.eprintf "@ %a = %a" Lm_symbol.pp_print_symbol v Omake_ir_print.pp_print_var_info info) ir.ir_vars; Format.eprintf "@]@." end; source, ir.ir_vars (* * The include file contains the IR for the file. * Try to load the old entry. * If it fails, compile the file and save the new entry. *) and compile_add_ir_info venv scope pos _ source info = let _pos = string_pos "compile_add_ir_info" pos in try Omake_env.Static.get_ir info with Not_found -> let ir = parse_ir venv scope source in Omake_env.Static.add_ir info ir; ir and compile_ir_info venv scope pos loc source info = let _pos = string_pos "compile_ir_info" pos in try Omake_env.Static.find_ir info with Not_found -> Omake_env.Static.rewrite info (compile_add_ir_info venv scope pos loc source) and compile_ir venv scope pos loc source = let pos = string_pos "compile_ir" pos in (* * Try to get a cached copy. *) try Omake_env.venv_find_ir_file_exn venv source with Not_found -> let ir = (* * Open the database. *) try Omake_env.Static.read venv source (compile_ir_info venv scope pos loc source) with Not_found -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringNodeError ("can't open IR", source))) in Omake_env.venv_add_ir_file venv source ir; ir (* * The object file contains the evaluated file. *) and compile_add_object_info compile _ pos source info = let _pos = string_pos "compile_add_object_info_info" pos in try Omake_env.Static.get_object info with Not_found -> let obj = compile info source in Omake_env.Static.add_object info obj; obj (* * Try to load the old entry. * If it fails, compile the file and save the new entry. *) and compile_object_info compile venv pos source info = let _pos = string_pos "compile_object_info" pos in try Omake_env.Static.find_object info with Not_found -> Omake_env.Static.rewrite info (compile_add_object_info compile venv pos source) and compile_object compile venv pos loc source = let pos = string_pos "compile_ast" pos in (* * Try to get a cached copy. *) try Omake_env.venv_find_object_file_exn venv source with Not_found -> let obj = (* * Open the database. *) try Omake_env.Static.read venv source (compile_object_info compile venv pos source) with Not_found -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringNodeError ("can't open object", source))) in Omake_env.venv_add_object_file venv source obj; obj (************************************************************************ * Value operations. *) (* * Get the string representation of a value. * It not legal to convert an array to a string. *) and string_of_value venv pos (v : Omake_value_type.t) = let pos = string_pos "string_of_value" pos in let scratch_buf = Buffer.create 32 in let rec collect (v : Omake_value_type.t) = match eval_prim_value venv pos v with (* Values that expand to nothing *) | ValNone | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValBody _ | ValMap _ | ValObject _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValArray [] | ValVar _ -> () | ValSequence vl -> List.iter collect vl | ValQuote vl -> string_of_quote_buf scratch_buf venv pos vl | ValQuoteString (c, vl) -> Buffer.add_char scratch_buf c; string_of_quote_buf scratch_buf venv pos vl; Buffer.add_char scratch_buf c | ValArray [v] -> collect v | ValArray vl -> let print_error buf = Format.fprintf buf "@[Array value where string expected:"; Format.fprintf buf "@ Use the $(string ...) function if you really want to do this"; Format.fprintf buf "@ @[The array has length %d:" (List.length vl); ignore (List.fold_left (fun index v -> Format.fprintf buf "@ @[[%d] =@ %a@]" index Omake_value_print.pp_print_value v; succ index) 0 vl); Format.fprintf buf "@]@]@." in raise (Omake_value_type.OmakeException (pos, LazyError print_error)) | ValInt i -> Buffer.add_string scratch_buf (string_of_int i) | ValFloat x -> Buffer.add_string scratch_buf (string_of_float x) | ValData s | ValWhite s | ValString s -> Buffer.add_string scratch_buf s | ValDir dir2 -> Buffer.add_string scratch_buf (Omake_env.venv_dirname venv dir2) | ValNode node -> Buffer.add_string scratch_buf (Omake_env.venv_nodename venv node) | ValStringExp _ | ValMaybeApply _ | ValDelayed _ -> raise (Invalid_argument "string_of_value") in collect v; Buffer.contents scratch_buf (* * Collect the values in a quotation into a string. * Even array values are flattened without warning. *) and string_of_quote venv pos c vl = let pos = string_pos "string_of_quote" pos in let scratch_buf = Buffer.create 32 in buffer_add_quote scratch_buf c; string_of_quote_buf scratch_buf venv pos vl; buffer_add_quote scratch_buf c; Buffer.contents scratch_buf and string_of_quote_buf scratch_buf venv pos vl = let pos = string_pos "string_of_quote_buf" pos in let rec collect v = match (eval_value venv pos v : Omake_value_type.t) with (* Values that expand to nothing *) | ValNone | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValBody _ | ValMap _ | ValObject _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValArray [] | ValVar _ -> () | ValSequence vl | ValQuote vl -> List.iter collect vl | ValQuoteString (c, vl) -> Buffer.add_char scratch_buf c; List.iter collect vl; Buffer.add_char scratch_buf c | ValArray [v] -> collect v | ValArray vl -> collect_array vl | ValInt i -> Buffer.add_string scratch_buf (string_of_int i) | ValFloat x -> Buffer.add_string scratch_buf (string_of_float x) | ValData s | ValWhite s | ValString s -> Buffer.add_string scratch_buf s | ValDir dir2 -> Buffer.add_string scratch_buf (Omake_env.venv_dirname venv dir2) | ValNode node -> Buffer.add_string scratch_buf (Omake_env.venv_nodename venv node) | ValStringExp _ | ValMaybeApply _ | ValDelayed _ -> raise (Invalid_argument "string_of_value") and collect_array vl = match vl with [v] -> collect v | v :: vl -> collect v; Buffer.add_char scratch_buf ' '; collect_array vl | [] -> () in List.iter collect vl (* * Get a list of values from the value. * Array elements are always special, and returned as an element. * We divide values into two classes: * The "catenable" values are the values that can be concatenated to * form a string. These include: string, node, dir, int, float. * * Nothing else can be concatenated with a string, and is always preserved * in the value list. *) and values_of_value venv pos v = let pos = string_pos "values_of_value" pos in (* * Convert a catenable value to a string *) let group tokens : Omake_value_type.t = ValSequence tokens in let wrap_string s : Omake_value_type.t = ValString s in let wrap_data s : Omake_value_type.t = ValData s in let wrap_token s : Omake_value_type.t = ValData s in let lexer _ _ _ = None in let tokens = Lm_string_util.tokens_create_lexer ~lexer ~wrap_string ~wrap_data ~wrap_token ~group in (* * Array elements are always separate values. * The arrays are flattened. *) let rec collect_array tokens (vl : Omake_value_type.t list) vll = match vl, vll with | v :: vl, _ -> begin match eval_value venv pos v with ValArray el -> collect_array tokens el (vl :: vll) | ValSequence [v] -> collect_array tokens (v :: vl) vll | v -> collect_array (Lm_string_util.tokens_atomic tokens v) vl vll end | [], vl :: vll -> collect_array tokens vl vll | [], [] -> tokens in (* * Collect_string is used when we have seen whitespace * in a sequence. Collect the values into the string buffer, * then parse the string into separate tokens. *) let rec collect tokens vl vll = match vl, vll with | v :: vl, _ -> let v : Omake_value_type.t = eval_catenable_value venv pos v in begin match v with | ValNone -> collect tokens vl vll (* Strings *) | ValWhite s | ValString s -> collect (Lm_string_util.tokens_string tokens s) vl vll | ValSequence el -> collect tokens el (vl :: vll) (* Other catenable values *) | ValData _ | ValInt _ | ValFloat _ | ValDir _ | ValNode _ | ValQuote _ | ValQuoteString _ -> collect (Lm_string_util.tokens_add tokens v) vl vll (* Atomic values *) | ValArray el -> collect (collect_array (Lm_string_util.tokens_break tokens) el []) vl vll | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValBody _ | ValMap _ | ValObject _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValVar _ -> collect (Lm_string_util.tokens_atomic tokens v) vl vll | ValStringExp _ | ValMaybeApply _ | ValDelayed _ -> raise (Omake_value_type.OmakeException (pos, StringValueError ("illegal application", v))) end | [], vl :: vll -> collect tokens vl vll | [], [] -> Lm_string_util.tokens_flush tokens in collect tokens [v] [] (* * Get a string list from the value. * This is always legal because arrays have been flattened. *) and strings_of_value venv pos v = let values = values_of_value venv pos v in List.map (string_of_value venv pos) values (* * Get a list of tokens from the value. * This is a lot like the previous function, but we use a lexer * for parsing special character sequences. *) and tokens_of_value venv pos lexer v = let pos = string_pos "tokens_of_value" pos in (* * Convert a catenable value to a string *) let group tokens = Omake_env.TokGroup tokens in let wrap_string s = Omake_env.TokString (ValString s) in let wrap_data s = Omake_env.TokString (ValData s) in let wrap_token s = Omake_env.TokToken s in let tokens = Lm_string_util.tokens_create_lexer ~lexer ~wrap_string ~wrap_data ~wrap_token ~group in (* * Array elements are always separate values. * The arrays are flattened. *) let rec collect_array (tokens : Omake_env.tok Lm_string_util.tokens) vl vll = match vl, vll with v :: vl, _ -> (match eval_value venv pos v with ValArray el -> collect_array tokens el (vl :: vll) | ValSequence [v] -> collect_array tokens (v :: vl) vll | v -> collect_array (Lm_string_util.tokens_atomic tokens (TokString v)) vl vll) | [], vl :: vll -> collect_array tokens vl vll | [], [] -> tokens in (* * Collect_string is used when we have seen whitespace * in a sequence. Collect the values into the string buffer, * then parse the string into separate tokens. *) let rec collect (tokens : Omake_env.tok Lm_string_util.tokens) vl vll = match vl, vll with v :: vl, _ -> let v = eval_catenable_value venv pos v in (match v with ValNone -> collect tokens vl vll (* Strings *) | ValWhite s | ValString s -> collect (Lm_string_util.tokens_lex tokens s) vl vll | ValSequence el -> collect tokens el (vl :: vll) (* Other catenable values *) | ValData _ | ValInt _ | ValFloat _ | ValDir _ | ValNode _ | ValQuote _ -> collect (Lm_string_util.tokens_add tokens (TokString v)) vl vll | ValQuoteString (_, v) -> collect (Lm_string_util.tokens_add tokens (TokString (ValQuote v))) vl vll (* Atomic values *) | ValArray el -> collect (collect_array (Lm_string_util.tokens_break tokens) el []) vl vll | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValBody _ | ValMap _ | ValObject _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValVar _ -> collect (Lm_string_util.tokens_atomic tokens (TokString v)) vl vll | ValStringExp _ | ValMaybeApply _ | ValDelayed _ -> raise (Omake_value_type.OmakeException (pos, StringValueError ("illegal application", v)))) | [], vl :: vll -> collect tokens vl vll | [], [] -> Lm_string_util.tokens_flush tokens in collect tokens [v] [] (* * Flatten the value list into a arg_string list. * Basically just concatenate all the values, being * careful to preserve quoting. In addition, we want to * concatenate adjacent strings of the same type. *) and arg_of_values venv pos vl = let pos = string_pos "arg_of_values" pos in (* * Flatten all sequences. *) let rec collect is_quoted tokens vl vll = match vl, vll with v :: vl, _ -> let v = eval_value venv pos v in (match v with ValNone -> collect is_quoted tokens vl vll (* Strings *) | ValWhite s | ValString s -> let tokens = if is_quoted then Omake_command.arg_buffer_add_data tokens s else Omake_command.arg_buffer_add_string tokens s in collect is_quoted tokens vl vll | ValData s -> collect is_quoted (Omake_command.arg_buffer_add_data tokens s) vl vll | ValSequence el -> collect is_quoted tokens el (vl :: vll) | ValArray el -> collect true tokens el (vl :: vll) (* Other quoted values *) | ValInt _ | ValFloat _ | ValDir _ | ValNode _ | ValQuote _ | ValQuoteString _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValBody _ | ValMap _ | ValObject _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValVar _ -> let tokens = Omake_command.arg_buffer_add_data tokens (string_of_value venv pos v) in collect is_quoted tokens vl vll (* Illegal values *) | ValStringExp _ | ValMaybeApply _ | ValDelayed _ -> raise (Omake_value_type.OmakeException (pos, StringValueError ("illegal application", v)))) | [], vl :: vll -> collect is_quoted tokens vl vll | [], [] -> Omake_command.arg_buffer_contents tokens in collect false Omake_command.arg_buffer_empty vl [] and argv_of_values venv pos vll = List.map (arg_of_values venv pos) vll (* * Boolean test. * Arrays are always true. *) and bool_of_value venv pos v = let values = values_of_value venv pos v in match values with [] | [ValNone] | [ValWhite _] -> false | [ValInt i] -> i <> 0 | [ValFloat x] -> x <> 0.0 | [ValData s] | [ValString s] -> bool_of_string s | [ValQuote vl] -> bool_of_string (string_of_quote venv pos None vl) | _ -> true (* * The value should be a directory. *) and file_of_value venv pos file = let pos = string_pos "file_of_value" pos in let file = eval_prim_value venv pos file in match file with ValNode node -> node | ValDir dir -> Omake_node.Node.node_of_dir dir | ValData _ | ValString _ | ValSequence _ | ValQuote _ | ValQuoteString _ | ValInt _ | ValFloat _ -> Omake_env.venv_intern venv PhonyExplicit (string_of_value venv pos file) | ValArray _ | ValNone | ValWhite _ | ValMaybeApply _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValStringExp _ | ValBody _ | ValMap _ | ValObject _ | ValChannel _ | ValClass _ | ValCases _ | ValVar _ | ValDelayed _ | ValOther _ -> raise (Omake_value_type.OmakeException (pos, StringError "illegal value")) (* * Be lazy about concatenating arrays, to * avoid quadratic behavior. *) and append_arrays venv pos a1 a2 : Omake_value_type.t = if is_array_value a1 then if is_array_value a2 then ValArray [a1; a2] else let al = values_of_value venv pos a2 in ValArray (a1 :: al) else if is_array_value a2 then let al = values_of_value venv pos a1 in ValArray [ValArray al; a2] else if is_empty_value a1 then a2 else if is_empty_value a2 then a1 else ValSequence [a1; ValWhite " "; a2] (************************************************************************ * Evaluation. *) (* * Eval a static value. *) and eval_value_static venv pos key v = let pos = string_pos "eval_value_static" pos in let obj = match Omake_env.venv_find_static_info venv pos key with StaticValue obj -> obj | StaticRule { srule_env = venv; srule_deps = deps; srule_vals = values; srule_exp = e; srule_static ; _ } -> let values = List.flatten (List.map (values_of_value venv pos) values) in let values = List.map (eval_prim_value venv pos) values in let digest = Omake_command_digest.digest_of_exp pos values e in let cache = Omake_env.venv_cache venv in let obj = (* Try to fetch the value from the memo *) try Omake_cache.find_value cache key srule_static deps digest with Not_found -> (* Finally, if we don't have a value, evaluate the rule. * Prevent recursive calls *) let () = Omake_env.venv_set_static_info venv key (StaticValue Omake_value_util.empty_obj) in let venv, v = eval_exp venv Omake_value_type.ValNone e in let obj = eval_object venv pos v in Omake_cache.add_value cache key srule_static deps digest (MemoSuccess obj); obj in Omake_env.venv_set_static_info venv key (StaticValue obj); obj in Omake_env.venv_find_field_internal obj pos v and eval_value_delayed venv pos (p : Omake_value_type.value_delayed ref) = match !p with | ValValue v -> eval_value_core venv pos v | ValStaticApply (key, v) -> let v = eval_value_static venv pos key v in p := ValValue v; eval_value_core venv pos v (* * Unfold the outermost application to get a real value. *) and eval_value_core venv pos v : Omake_value_type.t = match v with | ValMaybeApply (loc, v) -> let v = try Some (Omake_env.venv_find_var_exn venv v) with Not_found -> None in begin match v with | Some v -> ValArray [eval_value_core venv pos (eval_var venv pos loc v)] | None -> ValNone end | ValDelayed p -> eval_value_delayed venv pos p | ValSequence [v] -> eval_value_core venv pos v | ValStringExp (env, e) -> let v = eval_string_exp (Omake_env.venv_with_env venv env) pos e in eval_value_core venv pos v | _ -> v and eval_value venv pos v = let pos = string_pos "eval_value" pos in eval_value_core venv pos v and eval_single_value venv pos v = let pos = string_pos "eval_single_value" pos in match eval_value venv pos v with ValArray [v] -> eval_single_value venv pos v | _ -> v and eval_prim_value venv pos v : Omake_value_type.t = let pos = string_pos "eval_prim_value" pos in let v = eval_value venv pos v in match v with ValArray [v] -> eval_prim_value venv pos v | ValObject obj -> (try Omake_env.venv_find_field_internal_exn obj Omake_symbol.builtin_sym with Not_found -> v) | _ -> v (* * The values are being flattened, so expand all sequences. *) and eval_catenable_value venv pos v = let pos = string_pos "eval_catenable_value" pos in let v = eval_value venv pos v in match v with ValObject obj -> (try match Omake_env.venv_find_field_internal_exn obj Omake_symbol.builtin_sym with ValNone | ValWhite _ | ValString _ | ValSequence _ | ValData _ | ValInt _ | ValFloat _ | ValDir _ | ValNode _ | ValArray _ | ValRules _ as v -> v | _ -> v with Not_found -> v) | _ -> v (* * Evaluate the value in a function body. * Expand all applications. *) and eval_body_value venv pos v : Omake_value_type.t = match (eval_value venv pos v : Omake_value_type.t) with | ValSequence sl -> ValSequence (List.map (eval_body_value venv pos) sl) | ValArray sl -> ValArray (List.map (eval_body_value venv pos) sl) | ValBody (_, [], [], body, _) -> snd (eval_sequence_exp venv pos body) | ValNone | ValInt _ | ValFloat _ | ValData _ | ValWhite _ | ValString _ | ValQuote _ | ValQuoteString _ | ValDir _ | ValNode _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValMap _ | ValObject _ | ValChannel _ | ValClass _ | ValCases _ | ValVar _ | ValOther _ as result -> result | ValBody _ (* it is an error when keyword/params <> [] *) | ValStringExp _ | ValMaybeApply _ | ValDelayed _ -> raise (Invalid_argument "eval_body_value") and eval_body_exp venv pos x v : (Omake_env.t * Omake_value_type.t) = match (eval_value venv pos v : Omake_value_type.t) with | ValSequence sl -> venv, ValSequence (List.map (eval_body_value venv pos) sl) | ValArray sl -> venv, ValArray (List.map (eval_body_value venv pos) sl) | ValBody (_, [], [], body, export) -> eval_sequence_export venv pos x body export | ValNone | ValInt _ | ValFloat _ | ValData _ | ValQuote _ | ValQuoteString _ | ValWhite _ | ValString _ | ValDir _ | ValNode _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValMap _ | ValObject _ | ValChannel _ | ValClass _ | ValCases _ | ValVar _ | ValOther _ as result -> venv, result | ValBody _ (* it is an error when keyword/params <> [] *) | ValStringExp _ | ValMaybeApply _ | ValDelayed _ -> raise (Invalid_argument "eval_body_exp") (* * Evaluate a variable. * It is fine for the variable to evaluate to a function. * But if the function has arity 0, then evaluate it. *) and eval_var venv pos loc v = match v with | ValFun (env, _, [], body, _) -> let venv = Omake_env.venv_with_env venv env in let _, result = eval_sequence venv pos Omake_value_type.ValNone body in result | ValFunCurry (env, args, _, [], body, _, []) -> let venv = Omake_env.venv_with_partial_args venv env args in let _, result = eval_sequence venv pos ValNone body in result | ValFunCurry (env, args, _, [], body, export, kargs) -> (* XXX: verify that we should pass forward the exports *) let venv_new = Omake_env.venv_with_partial_args venv env args in let venv_new, v = eval_sequence venv_new pos ValNone body in let venv = Omake_env.add_exports venv venv_new pos export in eval_apply venv pos loc v [] kargs | ValPrim (_, _, ApplyEmpty, f) -> snd (Omake_env.venv_apply_prim_fun f venv pos loc [] []) | _ -> v (* * Evaluate a key. *) and eval_key venv pos loc v = try let map = eval_map venv pos (Omake_env.venv_find_var_exn venv Omake_var.map_field_var) in Omake_env.venv_map_find map pos (ValData v) with Not_found -> raise (Omake_value_type.OmakeException (loc_pos loc pos, UnboundKey v)) (* * Evaluate an application. *) and eval_apply venv pos loc v args kargs = let pos = string_pos "eval_apply" pos in match eval_value venv pos v with ValFun (env, keywords, params, body, _) -> let venv = Omake_env.venv_add_args venv pos loc env params args keywords kargs in let _, result = eval_sequence_exp venv pos body in result | ValFunCurry (env, pargs, keywords, params, body, export, kargs1) -> let venv_new, args, kargs = Omake_env.venv_add_curry_args venv pos loc env pargs params args keywords kargs1 kargs in let venv_new, v = eval_sequence_exp venv_new pos body in let venv = Omake_env.add_exports venv venv_new pos export in eval_apply venv pos loc v args kargs | ValPrim (_, _, _, f) -> snd (Omake_env.venv_apply_prim_fun f venv pos loc args kargs) | ValPrimCurry (_, _, f, args1, kargs1) -> snd (Omake_env.venv_apply_prim_fun f venv pos loc (List.rev_append args1 args) (List.rev_append kargs1 kargs)) | ValBody (env, keywords, params, body, exports) when keywords <> [] || params <> [] -> let v = Omake_value_type.ValFun(env, keywords, params, body, exports) in eval_apply venv pos loc v args kargs | v -> if args = [] && kargs = [] then v else let print_error buf = Format.fprintf buf "@[illegal function application:@ @[function:@ %a@]" Omake_value_print.pp_print_value v; List.iter (fun arg -> Format.fprintf buf "@ @[arg = %a@]" Omake_value_print.pp_print_value arg) args; List.iter (fun (v, arg) -> Format.fprintf buf "@ @[%a = %a@]" Lm_symbol.pp_print_symbol v Omake_value_print.pp_print_value arg) kargs; Format.fprintf buf "@]" in raise (Omake_value_type.OmakeException (pos, LazyError print_error)) (* * Evaluate an application with string arguments. *) and eval_apply_string_exp venv venv_obj pos loc v args kargs = let pos = string_pos "eval_apply_string_exp" pos in match eval_value venv pos v with ValFun (env, keywords, params, body, _) -> let args = List.map (eval_string_exp venv pos) args in let kargs = List.map (fun (v, s) -> v, eval_string_exp venv pos s) kargs in let venv_new = Omake_env.venv_add_args venv_obj pos loc env params args keywords kargs in let _, result = eval_sequence_exp venv_new pos body in result | ValFunCurry (env, pargs, keywords, params, body, export, kargs1) -> let args = List.map (eval_string_exp venv pos) args in let kargs = List.map (fun (v, s) -> v, eval_string_exp venv pos s) kargs in let venv_new, args, kargs = Omake_env.venv_add_curry_args venv_obj pos loc env pargs params args keywords kargs1 kargs in let venv_new, v = eval_sequence_exp venv_new pos body in let venv = Omake_env.add_exports venv venv_new pos export in eval_apply venv pos loc v args kargs | ValPrim (_, be_eager, _, f) -> let args = List.map (eval_prim_arg_exp be_eager venv pos) args in let kargs = List.map (fun (v, s) -> v, eval_prim_arg_exp true venv pos s) kargs in snd (Omake_env.venv_apply_prim_fun f venv_obj pos loc args kargs) | ValPrimCurry (_, be_eager, f, args1, kargs1) -> let args = List.map (eval_prim_arg_exp be_eager venv pos) args in let kargs = List.map (fun (v, s) -> v, eval_prim_arg_exp true venv pos s) kargs in snd (Omake_env.venv_apply_prim_fun f venv_obj pos loc (List.rev_append args1 args) (List.rev_append kargs1 kargs)) | ValBody (env, keywords, params, body, exports) when keywords <> [] || params <> [] -> let v = Omake_value_type.ValFun(env, keywords, params, body, exports) in eval_apply_string_exp venv venv_obj pos loc v args kargs | v -> if args = [] && kargs = [] then v else let print_error buf = Format.fprintf buf "@[illegal function application:@ @[function:@ %a@]" Omake_value_print.pp_print_value v; List.iter (fun arg -> Format.fprintf buf "@ @[arg = %a@]" Omake_ir_print.pp_print_string_exp arg) args; List.iter (fun (v, arg) -> Format.fprintf buf "@ @[%a = %a@]" Lm_symbol.pp_print_symbol v Omake_ir_print.pp_print_string_exp arg) kargs; Format.fprintf buf "@]" in raise (Omake_value_type.OmakeException (pos, LazyError print_error)) (* * Get a function from a value. *) and eval_fun ?(caller_env=false) venv pos v = match eval_value venv pos v with ValFun (env, keywords, params, body, export) -> let f venv pos loc args kargs = let venv_new = Omake_env.venv_add_args venv pos loc env params args keywords kargs in let venv_new, result = eval_sequence_exp venv_new pos body in let venv = Omake_env.add_exports venv venv_new pos export in venv, result in true, f | ValFunCurry (env, pargs, keywords, params, body, export, kargs1) -> let f venv pos loc args kargs = let venv_new, args, kargs = Omake_env.venv_add_curry_args venv pos loc env pargs params args keywords kargs1 kargs in let venv_new, v = eval_sequence_exp venv_new pos body in let venv = Omake_env.add_exports venv venv_new pos export in eval_apply_export venv pos loc v args kargs in true, f | ValPrim (_, be_eager, _, f) -> be_eager, Omake_env.venv_apply_prim_fun f | ValPrimCurry (_, be_eager, f, args1, kargs1) -> let f venv pos loc args2 kargs2 = Omake_env.venv_apply_prim_fun f venv pos loc (List.rev_append args1 args2) (List.rev_append kargs1 kargs2) in be_eager, f | ValBody (defenv, keywords, params, body, export) -> let f venv pos loc args kargs = let env = (* diff to ValFun! *) if caller_env then Omake_env.venv_get_env venv else defenv in let venv_new = Omake_env.venv_add_args venv pos loc env params args keywords kargs in let venv_new, result = eval_sequence_exp venv_new pos body in let venv = Omake_env.add_exports venv venv_new pos export in venv, result in true, f | _ -> raise (Omake_value_type.OmakeException (pos, StringError "not a function")) and definition_env_of_fun venv pos v = match eval_value venv pos v with | ValFun (env, _, _, _, _) -> env | ValFunCurry (env, _, _, _, _, _, _) -> env | ValBody (env, _, _, _, _) -> env | ValPrim _ | ValPrimCurry _ -> Omake_env.venv_get_env venv | _ -> raise (Omake_value_type.OmakeException (pos, StringError "not a function")) (* * Get an object from a variable. *) and eval_map venv pos x = match eval_value venv pos x with ValMap map -> map | _ -> raise (Omake_value_type.OmakeException (pos, StringError "not a map")) and eval_object venv pos x = try eval_object_exn venv pos x with Not_found -> raise (Omake_value_type.OmakeException (pos, StringError "not an object")) and eval_object_exn venv pos x = let x = eval_value venv pos x in match x with ValObject env -> env | ValInt _ | ValOther (ValExitCode _) -> create_object venv x Omake_var.int_object_var | ValFloat _ -> create_object venv x Omake_var.float_object_var | ValData _ | ValQuote _ | ValQuoteString _ -> create_object venv x Omake_var.string_object_var | ValSequence _ | ValWhite _ | ValString _ | ValNone -> create_object venv x Omake_var.sequence_object_var | ValArray _ -> create_object venv x Omake_var.array_object_var | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ -> create_object venv x Omake_var.fun_object_var | ValRules _ -> create_object venv x Omake_var.rule_object_var | ValNode _ -> create_object venv x Omake_var.file_object_var | ValDir _ -> create_object venv x Omake_var.dir_object_var | ValBody (env, keywords, params, body, exports) when keywords <> [] || params <> [] -> let x = Omake_value_type.ValFun(env, keywords, params, body, exports) in eval_object_exn venv pos x | ValBody _ -> create_object venv x Omake_var.body_object_var | ValChannel (InChannel, _) -> create_object venv x Omake_var.in_channel_object_var | ValChannel (OutChannel, _) -> create_object venv x Omake_var.out_channel_object_var | ValChannel (InOutChannel, _) -> create_object venv x Omake_var.in_out_channel_object_var | ValOther (ValLexer _) -> create_object venv x Omake_var.lexer_object_var | ValOther (ValParser _) -> create_object venv x Omake_var.parser_object_var | ValOther (ValLocation _) -> create_object venv x Omake_var.location_object_var | ValOther (ValEnv _) -> raise (Omake_value_type.OmakeException (pos, StringError "dereferenced ")) | ValClass _ -> raise (Invalid_argument "internal error: dereferenced $class") | ValCases _ -> raise (Invalid_argument "internal error: dereferenced cases") | ValMap _ -> create_map venv x Omake_var.map_object_var | ValVar _ -> create_object venv x Omake_var.var_object_var | ValStringExp _ | ValMaybeApply _ | ValDelayed _ -> raise (Invalid_argument "find_object") and create_object venv x v = let obj = Omake_env.venv_find_var_exn venv v in match obj with ValObject env -> Omake_env.venv_add_field_internal env Omake_symbol.builtin_sym x | _ -> raise Not_found and create_map venv x v = let obj = Omake_env.venv_find_var_exn venv v in match obj with ValObject env -> Omake_env.venv_add_field_internal env Omake_symbol.map_sym x | _ -> raise Not_found (* * Field operations. *) and eval_find_field_exn venv path obj pos vl = match vl with [v] -> path, obj, v | v :: vl -> let path, v = Omake_env.venv_find_field_path_exn venv path obj pos v in let obj = eval_object_exn venv pos v in eval_find_field_exn venv path obj pos vl | [] -> raise (Omake_value_type.OmakeException (pos, StringError "empty method name")) and eval_find_field_aux venv envl pos v vl = match envl with | [env] -> let env = eval_object_exn venv pos env in let path : Omake_value_type.path = PathVar v in eval_find_field_exn venv path env pos vl | env :: envl -> let env = eval_object_exn venv pos env in (try eval_find_field_exn venv (PathVar v) env pos vl with Not_found -> eval_find_field_aux venv envl pos v vl) | [] -> raise Not_found and eval_find_field venv pos _ v vl = let envl = Omake_env.venv_current_objects venv pos v in try eval_find_field_aux venv envl pos v vl with Not_found -> let pos = string_pos "eval_find_field" pos in raise (Omake_value_type.OmakeException (pos, UnboundMethod vl)) (* * Method paths. *) and eval_with_method_exn venv path obj pos vl = match vl with [v] -> let v = Omake_env.venv_find_field_exn venv obj pos v in let venv = Omake_env.venv_with_object venv obj in venv, path, v | v :: vl -> let path, v = Omake_env.venv_find_field_path_exn venv path obj pos v in let obj = eval_object_exn venv pos v in eval_with_method_exn venv path obj pos vl | [] -> raise (Omake_value_type.OmakeException (pos, StringError "empty method name")) and eval_with_method_aux venv envl pos v vl = match envl with | [env] -> let env = eval_object_exn venv pos env in eval_with_method_exn venv (PathVar v) env pos vl | env :: envl -> let env = eval_object_exn venv pos env in (try eval_with_method_exn venv (PathVar v) env pos vl with Not_found -> eval_with_method_aux venv envl pos v vl) | [] -> raise Not_found and eval_with_method venv pos loc v vl = let envl = Omake_env.venv_current_objects venv pos v in try eval_with_method_aux venv envl pos v vl with Not_found -> let pos = string_pos "eval_with_method" (loc_pos loc pos) in raise (Omake_value_type.OmakeException (pos, UnboundMethod vl)) (* * Method paths. *) and eval_find_method_exn venv obj pos vl = match vl with [v] -> let v = Omake_env.venv_find_field_exn venv obj pos v in let venv = Omake_env.venv_with_object venv obj in venv, v | v :: vl -> let v = Omake_env.venv_find_field_exn venv obj pos v in let obj = eval_object_exn venv pos v in eval_find_method_exn venv obj pos vl | [] -> raise (Omake_value_type.OmakeException (pos, StringError "empty method name")) and eval_find_method_aux venv envl pos vl = match envl with [env] -> let env = eval_object_exn venv pos env in eval_find_method_exn venv env pos vl | env :: envl -> let env = eval_object_exn venv pos env in (try eval_find_method_exn venv env pos vl with Not_found -> eval_find_method_aux venv envl pos vl) | [] -> raise Not_found and eval_find_method venv pos loc v vl = let envl = Omake_env.venv_current_objects venv pos v in try eval_find_method_aux venv envl pos vl with Not_found -> let pos = string_pos "eval_find_method" (loc_pos loc pos) in raise (Omake_value_type.OmakeException (pos, UnboundMethod vl)) (* * Check whether a field is defined. *) and eval_defined_field_exn venv env pos vl = match vl with [v] -> Omake_env.venv_defined_field venv env v | v :: vl -> let v = Omake_env.venv_find_field_exn venv env pos v in let obj = eval_object_exn venv pos v in eval_defined_field_exn venv obj pos vl | [] -> raise (Omake_value_type.OmakeException (pos, StringError "empty method name")) and eval_defined_field_aux venv envl pos vl = match envl with [env] -> let env = eval_object_exn venv pos env in eval_defined_field_exn venv env pos vl | env :: envl -> let env = eval_object_exn venv pos env in (try eval_defined_field_exn venv env pos vl with Not_found -> eval_defined_field_aux venv envl pos vl) | [] -> raise Not_found and eval_defined_field venv pos _ v vl = let envl = Omake_env.venv_current_objects venv pos v in try eval_defined_field_aux venv envl pos vl with Not_found -> false (* * Simplify a quoted value if possible. * Strings are concatenated. *) and simplify_quote_val venv pos c (el : Omake_value_type.t list) : Omake_value_type.t = let buf = Buffer.create 32 in let flush vl : Omake_value_type.t list = if Buffer.length buf = 0 then vl else let s = Buffer.contents buf in Buffer.clear buf; ValData s :: vl in let rec collect vl el = match el with | e :: el -> ( match eval_value venv pos e with | ValWhite s | ValString s | ValData s -> Buffer.add_string buf s; collect vl el | v -> collect (v :: flush vl) el ) | [] -> List.rev (flush vl) in let el = collect [] el in match c with | None -> (* GS: ValQuote just concatenates the inner elements without caring about sequences. Think about renaming to ValConcat. *) ( match el with | [ValData _ as e] -> e | _ -> ValQuote el ) | Some c -> ValQuoteString (c, el) (* * Evaluate a string expression. *) and eval_string_exp venv pos s = let pos = string_pos "eval_string_exp" pos in match s with NoneString _ -> ValNone | IntString (_, i) -> ValInt i | FloatString (_, x) -> ValFloat x | WhiteString (_, s) -> ValWhite s | ConstString (_, s) -> ValString s | KeyApplyString (loc, v) -> eval_key venv pos loc v | FunString (_, opt_params, params, body, export) -> let opt_params = eval_keyword_param_value_list_exp venv pos opt_params in let env = Omake_env.venv_get_env venv in (* We use now ValBody with parameters instead of ValFun for translating "=>..." blocks. ValFun has the disadvantage that it resets the static (private) variables every time the function is invoked. This doesn't play nice with foreach and potentially other imperative loop constructs. *) ValBody (env, opt_params, params, body, export) | ApplyString (loc, v, [], []) -> eval_var venv pos loc (Omake_env.venv_find_var venv pos loc v) | ApplyString (loc, v, args, kargs) -> eval_apply_string_exp venv venv pos loc (Omake_env.venv_find_var venv pos loc v) args kargs | SuperApplyString (loc, super, v, args, kargs) -> let v = Omake_env.venv_find_super_field venv pos loc super v in eval_apply_string_exp venv venv pos loc v args kargs | MethodApplyString (loc, v, vl, args, kargs) -> let venv_obj, v = eval_find_method venv pos loc v vl in eval_apply_string_exp venv venv_obj pos loc v args kargs | SequenceString (_, sl) -> ValSequence (List.map (eval_string_exp venv pos) sl) | ObjectString (_, e, export) | BodyString (_, e, export) -> let env = Omake_env.venv_get_env venv in ValBody (env, [], [], e, export) | ArrayString (_, el) -> ValArray (List.map (eval_string_exp venv pos) el) | ArrayOfString (_, e) -> let v = eval_string_exp venv pos e in ValArray (values_of_value venv pos v) | ExpString (_, e, _) -> let _, result = eval_sequence_exp venv pos e in result | CasesString (_, cases) -> let cases = List.map (fun (v, e1, e2, export) -> v, eval_string_exp venv pos e1, e2, export) cases in ValCases cases | QuoteString (_, el) -> simplify_quote_val venv pos None (List.map (eval_string_exp venv pos) el) | QuoteStringString (_, c, el) -> simplify_quote_val venv pos (Some c) (List.map (eval_string_exp venv pos) el) | VarString (loc, v) -> ValVar (loc, v) | ThisString _ -> ValObject (Omake_env.venv_this venv) | LazyString (_, s) -> ValStringExp (Omake_env.venv_get_env venv, s) | LetVarString (_, v, s1, s2) -> let x = eval_string_exp venv pos s1 in let venv = Omake_env.venv_add_var venv v x in eval_string_exp venv pos s2 (* and eval_keyword_string_exp venv pos (v, s) = *) (* v, eval_string_exp venv pos s *) and eval_keyword_param_value_list_exp venv pos opt_params = List.map (eval_keyword_param_value_exp venv pos) opt_params and eval_keyword_param_value_exp venv pos = function v, v_info, Some s -> v, v_info, Some (eval_string_exp venv pos s) | _, _, None as param -> param and eval_prim_arg_exp be_eager venv pos s = if be_eager then eval_string_exp venv pos s else ValStringExp (Omake_env.venv_get_env venv, s) (************************************************************************ * Export versions. * * These functions with the _export suffix also allow modifications * to the environment. *) and eval_var_export venv pos loc (v : Omake_value_type.t) = let pos = string_pos "eval_var_export" pos in (* Do not use eval_value; we don't want to force evaluation *) match v with | ValFun (env, _, [], body, export) -> let venv_new = Omake_env.venv_with_env venv env in let venv_new, result = eval_sequence venv_new pos ValNone body in let venv = Omake_env.add_exports venv venv_new pos export in venv, result | ValFunCurry (env, pargs, _, [], body, export, []) -> let venv_new = Omake_env.venv_with_partial_args venv env pargs in let venv_new, result = eval_sequence venv_new pos ValNone body in let venv = Omake_env.add_exports venv venv_new pos export in venv, result | ValFunCurry (env, pargs, _, [], body, export, kargs) -> let venv_new = Omake_env.venv_with_partial_args venv env pargs in let venv_new, v = eval_sequence venv_new pos ValNone body in let venv = Omake_env.add_exports venv venv_new pos export in eval_apply_export venv pos loc v [] kargs | ValPrim (_, _, ApplyEmpty, f) -> Omake_env.venv_apply_prim_fun f venv pos loc [] [] | _ -> venv, v (* * Evaluate an application. *) and eval_apply_export venv pos loc v args kargs = let pos = string_pos "eval_apply_export" pos in match (eval_value venv pos v : Omake_value_type.t) with | ValFun (env, keywords, params, body, export) -> let venv_new = Omake_env.venv_add_args venv pos loc env params args keywords kargs in let venv_new, result = eval_sequence_exp venv_new pos body in let venv = Omake_env.add_exports venv venv_new pos export in venv, result | ValFunCurry (env, pargs, keywords, params, body, export, kargs1) -> let venv_new, args, kargs = Omake_env.venv_add_curry_args venv pos loc env pargs params args keywords kargs1 kargs in let venv_new, v = eval_sequence_exp venv_new pos body in let venv = Omake_env.add_exports venv venv_new pos export in eval_apply_export venv pos loc v args kargs | ValPrim (_, _, _, f) -> Omake_env.venv_apply_prim_fun f venv pos loc args kargs | ValPrimCurry (_, _, f, args1, kargs1) -> Omake_env.venv_apply_prim_fun f venv pos loc (List.rev_append args1 args) (List.rev_append kargs1 kargs) | ValBody (env, keywords, params, body, exports) when keywords <> [] || params <> [] -> let v = Omake_value_type.ValFun(env, keywords, params, body, exports) in eval_apply_export venv pos loc v args kargs | v -> if args = [] && kargs = [] then venv, v else let print_error buf = Format.fprintf buf "@[illegal function application:@ @[function:@ %a@]" Omake_value_print.pp_print_value v; List.iter (fun arg -> Format.fprintf buf "@ @[arg = %a@]" Omake_value_print.pp_print_value arg) args; List.iter (fun (v, arg) -> Format.fprintf buf "@ @[%a = %a@]" Lm_symbol.pp_print_symbol v Omake_value_print.pp_print_value arg) kargs; Format.fprintf buf "@]" in raise (Omake_value_type.OmakeException (pos, LazyError print_error)) and eval_partial_apply venv pos loc v args kargs : (Omake_env.t * Omake_value_type.t )= match eval_value venv pos v with | ValFun (env, keywords, params, body, export) -> begin match (Omake_env.venv_add_partial_args venv pos loc env [] params args keywords [] kargs ) with | PartialApply (env, pargs, keywords, params, kargs) -> venv, ValFunCurry (env, pargs, keywords, params, body, export, kargs) | FullApply (venv, args, kargs) -> let venv_new, v = eval_sequence_exp venv pos body in let venv = Omake_env.add_exports venv venv_new pos export in eval_partial_apply venv pos loc v args kargs end | ValFunCurry (env, pargs, keywords, params, body, export, kargs1) -> (match Omake_env.venv_add_partial_args venv pos loc env pargs params args keywords kargs1 kargs with PartialApply (env, pargs, keywords, params, kargs) -> venv, ValFunCurry (env, pargs, keywords, params, body, export, kargs) | FullApply (venv, args, kargs) -> let venv_new, v = eval_sequence_exp venv pos body in let venv = Omake_env.add_exports venv venv_new pos export in eval_partial_apply venv pos loc v args kargs) | ValPrim (arity, eager, _, f) -> (match arity_apply_args arity [] args with FullArity (current_args, rest_args) -> (* We assume the primitive takes all the keyword args *) let venv, v = Omake_env.venv_apply_prim_fun f venv pos loc current_args kargs in eval_partial_apply venv pos loc v rest_args [] | PartialArity (arity, args) -> venv, ValPrimCurry (arity, eager, f, args, List.rev kargs)) | ValPrimCurry (arity, eager, f, args1, kargs1) -> (match arity_apply_args arity args1 args with FullArity (current_args, rest_args) -> (* We assume the primitive takes all the keyword args *) let venv, v = Omake_env.venv_apply_prim_fun f venv pos loc current_args kargs in eval_partial_apply venv pos loc v rest_args [] | PartialArity (arity, args) -> venv, ValPrimCurry (arity, eager, f, args, List.rev_append kargs kargs1)) | ValBody (env, keywords, params, body, exports) when keywords <> [] || params <> [] -> let v = Omake_value_type.ValFun(env, keywords, params, body, exports) in eval_partial_apply venv pos loc v args kargs | v -> if args = [] && kargs = [] then venv, v else let print_error buf = Format.fprintf buf "@[illegal function application:@ @[function:@ %a@]" Omake_value_print.pp_print_value v; List.iter (fun arg -> Format.fprintf buf "@ @[arg = %a@]" Omake_value_print.pp_print_value arg) args; List.iter (fun (v, arg) -> Format.fprintf buf "@ @[%a = %a@]" Lm_symbol.pp_print_symbol v Omake_value_print.pp_print_value arg) kargs; Format.fprintf buf "@]" in raise (Omake_value_type.OmakeException (pos, LazyError print_error)) and eval_apply_string_export_exp venv venv_new pos loc v args kargs = let pos = string_pos "eval_apply_string_export_exp" pos in match eval_value venv pos v with ValFun (env, keywords, params, body, export) -> let args = List.map (eval_string_exp venv pos) args in let kargs = List.map (fun (v, s) -> v, eval_string_exp venv pos s) kargs in let venv_new = Omake_env.venv_add_args venv_new pos loc env params args keywords kargs in let venv_new, result = eval_sequence_exp venv_new pos body in let venv = Omake_env.add_exports venv venv_new pos export in venv, result | ValFunCurry (env, pargs, keywords, params, body, export, kargs1) -> let args = List.map (eval_string_exp venv pos) args in let kargs = List.map (fun (v, s) -> v, eval_string_exp venv pos s) kargs in let venv_new, args, kargs = Omake_env.venv_add_curry_args venv_new pos loc env pargs params args keywords kargs1 kargs in let venv_new, v = eval_sequence_exp venv_new pos body in let venv = Omake_env.add_exports venv venv_new pos export in eval_apply_export venv pos loc v args kargs | ValPrim (_, be_eager, _, f) -> let args = List.map (eval_prim_arg_exp be_eager venv pos) args in let kargs = List.map (fun (v, s) -> v, eval_prim_arg_exp be_eager venv pos s) kargs in Omake_env.venv_apply_prim_fun f venv_new pos loc args kargs | ValPrimCurry (_, be_eager, f, args1, kargs1) -> let args = List.map (eval_prim_arg_exp be_eager venv pos) args in let kargs = List.map (fun (v, s) -> v, eval_prim_arg_exp be_eager venv pos s) kargs in Omake_env.venv_apply_prim_fun f venv_new pos loc (List.rev_append args1 args) (List.rev_append kargs1 kargs) | ValBody (env, keywords, params, body, exports) when keywords <> [] || params <> [] -> let v = Omake_value_type.ValFun(env, keywords, params, body, exports) in eval_apply_string_export_exp venv venv_new pos loc v args kargs | v -> if args = [] && kargs = [] then venv, v else let print_error buf = Format.fprintf buf "@[illegal function application:@ @[function:@ %a@]" Omake_value_print.pp_print_value v; List.iter (fun arg -> Format.fprintf buf "@ @[arg = %a@]" Omake_ir_print.pp_print_string_exp arg) args; List.iter (fun (v, arg) -> Format.fprintf buf "@ @[%a = %a@]" Lm_symbol.pp_print_symbol v Omake_ir_print.pp_print_string_exp arg) kargs; Format.fprintf buf "@]" in raise (Omake_value_type.OmakeException (pos, LazyError print_error)) and eval_apply_method_export_exp venv venv_obj pos loc path v args kargs = let pos = string_pos "eval_apply_method_export_exp" pos in match eval_value venv pos v with ValFun (env, keywords, params, body, export) -> let args = List.map (eval_string_exp venv pos) args in let kargs = List.map (fun (v, s) -> v, eval_string_exp venv pos s) kargs in let venv_new = Omake_env.venv_add_args venv_obj pos loc env params args keywords kargs in let venv_new, result = eval_sequence_exp venv_new pos body in let venv = Omake_env.add_path_exports venv venv_obj venv_new pos path export in venv, result | ValFunCurry (env, pargs, keywords, params, body, export, kargs1) -> (* XXX: JYH: this, need to think about *) let args = List.map (eval_string_exp venv pos) args in let kargs = List.map (fun (v, s) -> v, eval_string_exp venv pos s) kargs in let venv_new, args, kargs = Omake_env.venv_add_curry_args venv_obj pos loc env pargs params args keywords kargs1 kargs in let venv_new, v = eval_sequence_exp venv_new pos body in let venv = Omake_env.add_path_exports venv venv_obj venv_new pos path export in eval_apply_export venv pos loc v args kargs | ValPrim (_, be_eager, _, f) -> let args = List.map (eval_prim_arg_exp be_eager venv pos) args in let kargs = List.map (fun (v, s) -> v, eval_prim_arg_exp be_eager venv pos s) kargs in let venv_new, result = Omake_env.venv_apply_prim_fun f venv_obj pos loc args kargs in let venv = Omake_env.hoist_this venv venv_new path in venv, result | ValPrimCurry (_, be_eager, f, args1, kargs1) -> let args = List.map (eval_prim_arg_exp be_eager venv pos) args in let kargs = List.map (fun (v, s) -> v, eval_prim_arg_exp be_eager venv pos s) kargs in let venv_new, result = Omake_env.venv_apply_prim_fun f venv_obj pos loc (List.rev_append args1 args) (List.rev_append kargs1 kargs) in let venv = Omake_env.hoist_this venv venv_new path in venv, result | ValBody (env, keywords, params, body, exports) when keywords <> [] || params <> [] -> let v = Omake_value_type.ValFun(env, keywords, params, body, exports) in eval_apply_method_export_exp venv venv_obj pos loc path v args kargs | v -> if args = [] && kargs = [] then venv, v else let print_error buf = Format.fprintf buf "@[illegal function application:@ @[function:@ %a@]" Omake_value_print.pp_print_value v; List.iter (fun arg -> Format.fprintf buf "@ @[arg = %a@]" Omake_ir_print.pp_print_string_exp arg) args; List.iter (fun (v, arg) -> Format.fprintf buf "@ @[%a = %a@]" Lm_symbol.pp_print_symbol v Omake_ir_print.pp_print_string_exp arg) kargs; Format.fprintf buf "@]" in raise (Omake_value_type.OmakeException (pos, LazyError print_error)) (* * Evaluate a string expression, and allow exports. *) and eval_string_export_exp venv pos ( s : Omake_ir.string_exp) : (Omake_env.t * Omake_value_type.t)= let pos = string_pos "eval_string_export_exp" pos in match s with | NoneString _ -> venv, ValNone | IntString (_, i) -> venv, ValInt i | FloatString (_, x) -> venv, ValFloat x | WhiteString (_, s) -> venv, ValWhite s | ConstString (_, s) -> venv, ValString s | KeyApplyString (loc, v) -> venv, eval_key venv pos loc v | FunString (_, opt_params, params, body, export) -> let opt_params = eval_keyword_param_value_list_exp venv pos opt_params in let env = Omake_env.venv_get_env venv in venv, ValFun (env, opt_params, params, body, export) | ApplyString (loc, v, [], []) -> eval_var_export venv pos loc (Omake_env.venv_find_var venv pos loc v) | ApplyString (loc, v, args, kargs) -> eval_apply_string_export_exp venv venv pos loc (Omake_env.venv_find_var venv pos loc v) args kargs | SuperApplyString (loc, super, v, args, kargs) -> let v = Omake_env.venv_find_super_field venv pos loc super v in eval_apply_string_export_exp venv venv pos loc v args kargs | MethodApplyString (loc, v, vl, args, kargs) -> let venv_obj, path, v = eval_with_method venv pos loc v vl in eval_apply_method_export_exp venv venv_obj pos loc path v args kargs | SequenceString (_, sl) -> venv, ValSequence (List.map (eval_string_exp venv pos) sl) | ObjectString (_, e, export) | BodyString (_, e, export) -> let env = Omake_env.venv_get_env venv in venv, ValBody (env, [], [], e, export) | ArrayString (_, el) -> venv, ValArray (List.map (eval_string_exp venv pos) el) | ArrayOfString (_, e) -> let v = eval_string_exp venv pos e in venv, ValArray (values_of_value venv pos v) | ExpString (_, e, export) -> eval_sequence_export_exp venv pos e export | CasesString (_, cases) -> let cases = List.map (fun (v, e1, e2, export) -> v, eval_string_exp venv pos e1, e2, export) cases in venv, ValCases cases | QuoteString (_, el) -> venv, simplify_quote_val venv pos None (List.map (eval_string_exp venv pos) el) | QuoteStringString (_, c, el) -> venv, simplify_quote_val venv pos (Some c) (List.map (eval_string_exp venv pos) el) | VarString (loc, v) -> venv, ValVar (loc, v) | ThisString _ -> venv, ValObject (Omake_env.venv_this venv) | LazyString (_, s) -> venv, ValStringExp (Omake_env.venv_get_env venv, s) | LetVarString (_, v, s1, s2) -> let venv, x = eval_string_export_exp venv pos s1 in let venv = Omake_env.venv_add_var venv v x in eval_string_export_exp venv pos s2 (************************************************************************ * Evaluate an expression. *) and eval_exp venv _ e = let pos = string_pos "eval_exp" (ir_exp_pos e) in match e with LetVarExp (_, v, [], flag, s) -> eval_let_var_exp venv pos v flag s | LetVarExp (loc, v, vl, flag, s) -> eval_let_var_field_exp venv pos loc v vl flag s | LetKeyExp (_, v, flag, s) -> eval_let_key_exp venv pos v flag s | LetFunExp (loc, v, [], curry, opt_params, params, body, export) -> eval_let_fun_exp venv pos loc v curry opt_params params body export | LetFunExp (loc, v, vl, curry, opt_params, params, body, export) -> eval_let_fun_field_exp venv pos loc v vl curry opt_params params body export | LetObjectExp (_, v, [], s, e, export) -> eval_let_object_exp venv pos v s e export | LetObjectExp (loc, v, vl, s, e, export) -> eval_let_object_field_exp venv pos loc v vl s e export | LetThisExp (_, e) -> eval_let_this_exp venv pos e | ShellExp (loc, e) -> eval_shell_exp venv pos loc e | IfExp (_, cases) -> eval_if_exp venv pos cases | SequenceExp (_, e) -> eval_sequence_exp venv pos e | SectionExp (_, _, e, export) -> eval_section_exp venv pos e export | OpenExp (loc, s) -> eval_open_exp venv pos loc s | IncludeExp (loc, s, e) -> eval_include_exp venv pos loc s e | ApplyExp (loc, f, args, kargs) -> eval_apply_exp venv pos loc f args kargs | SuperApplyExp (loc, super, v, args, kargs) -> eval_super_apply_exp venv pos loc super v args kargs | MethodApplyExp (loc, v, vl, args, kargs) -> eval_method_apply_exp venv pos loc v vl args kargs | ReturnBodyExp (_, e, id) -> eval_return_body_exp venv pos e id | StringExp (_, s) -> eval_string_value_exp venv pos s | ReturnExp (loc, s, id) -> eval_return_exp venv pos loc s id | ReturnSaveExp _ -> eval_return_save_exp venv pos | ReturnObjectExp (_, names) -> eval_return_object_exp venv pos names | KeyExp (loc, v) -> eval_key_exp venv pos loc v | StaticExp (_, node, key, e) -> eval_static_exp venv pos node key e (* * Variable definitions. *) and eval_let_var_exp venv pos v flag s = let pos = string_pos "eval_var_exp" pos in let venv, s = eval_string_export_exp venv pos s in let s = match flag with VarDefNormal -> s | VarDefAppend -> append_arrays venv pos (Omake_env.venv_get_var venv pos v) s in let venv = Omake_env.venv_add_var venv v s in venv, s and eval_let_var_field_exp venv pos loc v vl flag s = let pos = string_pos "eval_var_field_exp" pos in let venv, e = eval_string_export_exp venv pos s in let path, obj, v = eval_find_field venv pos loc v vl in let e = match flag with VarDefNormal -> e | VarDefAppend -> append_arrays venv pos (Omake_env.venv_find_field venv obj pos v) e in let venv, obj = Omake_env.venv_add_field venv obj pos v e in let venv = Omake_env.hoist_path venv path obj in venv, e (* * Key (property) definitions. *) and eval_let_key_exp venv pos v flag s = let pos = string_pos "eval_let_key_exp" pos in let venv, s = eval_string_export_exp venv pos s in (* Get the current property list *) let map = try Omake_env.venv_find_var_exn venv Omake_var.map_field_var with Not_found -> raise (Omake_value_type.OmakeException (pos, StringError "current object is not a Map")) in let map = eval_map venv pos map in let v : Omake_value_type.t = ValData v in (* Add the new definition *) let s = match flag with | VarDefNormal -> s | VarDefAppend -> append_arrays venv pos (Omake_env.venv_map_find map pos v) s in let map = Omake_env.venv_map_add map pos v s in let venv = Omake_env.venv_add_var venv Omake_var.map_field_var (ValMap map) in venv, s (* * Function definitions. *) and eval_let_fun_exp venv pos _ v curry opt_params params body export = let opt_params = eval_keyword_param_value_list_exp venv pos opt_params in let env = Omake_env.venv_get_env venv in let e : Omake_value_type.t = if curry then ValFunCurry (env, [], opt_params, params, body, export, []) else ValFun (env, opt_params, params, body, export) in let venv = Omake_env.venv_add_var venv v e in venv, e and eval_let_fun_field_exp venv pos loc v vl curry opt_params params body export = let opt_params = eval_keyword_param_value_list_exp venv pos opt_params in let env = Omake_env.venv_get_env venv in let e : Omake_value_type.t = if curry then ValFunCurry (env, [], opt_params, params, body, export, []) else ValFun (env, opt_params, params, body, export) in let path, obj, v = eval_find_field venv pos loc v vl in let venv, obj = Omake_env.venv_add_field venv obj pos v e in let venv = Omake_env.hoist_path venv path obj in venv, e (* * Shell expression. *) and eval_shell_exp venv pos loc e = let pos = string_pos "eval_shell_exp" pos in let () = if !Omake_shell_type.debug_shell then Format.eprintf "@[eval_shell_exp (pid = %i):@ %a@]@." (**) (Unix.getpid()) Omake_ir_print.pp_print_string_exp e in let v = Omake_env.venv_find_var venv pos loc Omake_var.system_var in let venv, s = eval_string_export_exp venv pos e in eval_apply_export venv pos loc v [s] [] (* * Conditionals. * The test should expand to a Boolean of some form. *) and eval_if_cases venv pos cases = match cases with (s, el, export) :: cases -> let s = eval_string_exp venv pos s in let b = bool_of_value venv pos s in if b then eval_sequence_export_exp venv pos el export else eval_if_cases venv pos cases | [] -> venv, ValNone and eval_if_exp venv pos cases = let pos = string_pos "eval_if_exp" pos in eval_if_cases venv pos cases (* * Sequence. *) and eval_sequence venv pos result el = match el with e :: el -> let venv, result = eval_exp venv result e in eval_sequence venv pos result el | [] -> venv, result and eval_sequence_export venv pos result el export = let venv_new, result = eval_sequence venv pos result el in let venv = Omake_env.add_exports venv venv_new pos export in venv, result and eval_sequence_exp venv pos el = let pos = string_pos "eval_sequence_exp" pos in eval_sequence venv pos ValNone el and eval_sequence_export_exp venv pos el export = let pos = string_pos "eval_sequence_export_exp" pos in eval_sequence_export venv pos ValNone el export and eval_section_exp venv pos el export = let pos = string_pos "eval_section_exp" pos in eval_sequence_export venv pos ValNone el export (* * Look for a cached object. If it does not exist, * then evaluate the body to create the object. * Inline all the fields. *) and eval_static_exp venv pos node key el = let pos = string_pos "eval_static_exp" pos in let obj = try Omake_env.venv_find_static_object venv node key with Not_found -> (* Evaluate the object, and save it *) let _, result = eval_sequence (Omake_env.venv_define_object venv) pos ValNone el in let obj = eval_object venv pos result in Omake_env.venv_add_static_object venv node key obj; obj in let venv = Omake_env.venv_include_static_object venv obj in venv, ValNone (* * Object. * The argument string is ignored. * Push a new object. *) and eval_let_object_exp venv pos v s el export = let pos = string_pos "eval_let_object_exp" pos in let parent = eval_string_exp venv pos s in let obj = eval_object venv pos parent in let venv_obj = Omake_env.venv_define_object venv in let venv_obj = Omake_env.venv_include_object venv_obj obj in let venv_obj, result = eval_sequence venv_obj pos ValNone el in let venv = Omake_env.venv_add_var venv v result in let venv = Omake_env.add_exports venv venv_obj pos export in venv, result and eval_let_object_field_exp venv pos loc v vl s el export = let pos = string_pos "eval_let_object_field_exp" pos in let parent = eval_string_exp venv pos s in let obj = eval_object venv pos parent in let venv_obj = Omake_env.venv_define_object venv in let venv_obj = Omake_env.venv_include_object venv_obj obj in let venv_obj, e = eval_sequence venv_obj pos ValNone el in let path, obj, v = eval_find_field venv pos loc v vl in let venv, obj = Omake_env.venv_add_field venv obj pos v e in let venv = Omake_env.hoist_path venv path obj in let venv = Omake_env.add_exports venv venv_obj pos export in venv, e (* * This. * Set the current object to the given object. *) and eval_let_this_exp venv pos s = let pos = string_pos "eval_this_exp" pos in let venv, obj = eval_string_export_exp venv pos s in let obj = eval_object venv pos obj in let venv = Omake_env.venv_with_object venv obj in venv, ValObject obj (* * Include a file. * The environment after the file is evaluated is used in the rest * of this file. *) and eval_include_exp venv pos loc s _ = let pos = string_pos "eval_include" pos in let name = match eval_string_exp venv pos s with ValNode node -> (* Use an absolute name, preventing path lookup *) Omake_node.Node.absname node | name -> string_of_value venv pos name in let node = find_include_file venv pos loc name in let venv = Omake_env.venv_add_file venv node in let venv = include_file venv Omake_env.IncludePervasives pos loc node in venv, ValNone (* * Open a file. * Include it if it is not already included. *) and eval_open_exp venv pos loc nodes = let pos = string_pos "eval_open" pos in let venv = List.fold_left (fun venv node -> if Omake_env.venv_is_included_file venv node then venv else let venv = Omake_env.venv_add_file venv node in include_file venv Omake_env.IncludePervasives pos loc node) venv nodes in venv, ValNone (* * Key lookup. *) and eval_key_exp venv pos loc v = let pos = string_pos "eval_key_exp" pos in let result = eval_key venv pos loc v in venv, result (* * Function application. *) and eval_apply_exp venv pos loc f args kargs = let pos = string_pos "eval_apply_exp" pos in eval_apply_string_export_exp venv venv pos loc (Omake_env.venv_find_var venv pos loc f) args kargs and eval_super_apply_exp venv pos loc super v args kargs = let pos = string_pos "eval_super_apply_exp" pos in let v = Omake_env.venv_find_super_field venv pos loc super v in eval_apply_string_export_exp venv venv pos loc v args kargs and eval_method_apply_exp venv pos loc v vl args kargs = let pos = string_pos "eval_method_apply_exp" pos in let venv_obj, path, v = eval_with_method venv pos loc v vl in eval_apply_method_export_exp venv venv_obj pos loc path v args kargs (* * Return a value. This is just the identity. *) and eval_return_body_exp venv pos e id = let _pos = string_pos "eval_return_body_exp" pos in try eval_sequence_exp venv pos e with Omake_value_type.Return (_, v, id') when id' == id -> venv, v and eval_return_exp venv pos loc s id = let pos = string_pos "eval_return_exp" pos in let result = eval_string_exp venv pos s in raise (Omake_value_type.Return (loc, result, id)) and eval_string_value_exp venv pos s = let pos = string_pos "eval_string_value_exp" pos in let result = eval_string_exp venv pos s in venv, result and eval_return_save_exp venv pos = let _pos = string_pos "eval_return_save_exp" pos in venv, ValNone and eval_return_object_exp venv _ names = let result = Omake_env.venv_current_object venv names in venv, ValObject result (* * Include a file. *) and eval_include_file venv scope pos loc node = let ir = compile_ir venv scope pos loc node in let venv_new = Omake_env.venv_add_var venv Omake_var.file_var (ValNode node) in let venv_new, result = eval_exp venv_new ValNone ir.ir_exp in let venv = Omake_env.add_exports venv venv_new pos ExportAll in venv, result and include_file venv scope pos loc target = let pos = string_pos "include_file" pos in let venv = Omake_env.venv_add_included_file venv target in let venv, _ = eval_include_file venv scope pos loc target in venv (* * Parse and evaluate a file as if it were an object. *) and eval_object_file venv pos loc node = let parse_obj info node = let ir = compile_add_ir_info venv IncludePervasives pos loc node info in match ir with { ir_classnames = names; ir_exp = e; _} -> let venv = Omake_env.venv_get_pervasives venv node in let venv = Omake_env.venv_define_object venv in let venv, _ = eval_exp venv ValNone e in Omake_env.venv_current_object venv names in compile_object parse_obj venv pos loc node (************************************************************************ * Evaluator. *) and eval venv e = let _, result = eval_exp venv ValNone e in result let eval_open_file = open_ir let eval_apply = eval_apply_export (************************************************************************ * Project compiler. *) let compile venv = let rootname = if Sys.file_exists Omake_state.makeroot_name then Omake_state.makeroot_name else Omake_state.makeroot_short_name in let node = Omake_env.venv_intern venv PhonyProhibited rootname in let venv = Omake_env.venv_add_file venv node in let loc = Lm_location.bogus_loc (Omake_node.Node.fullname node) in let pos = string_pos "compile" (loc_exp_pos loc) in let _ = eval_include_file venv IncludePervasives pos loc node in if Lm_debug.debug print_rules then Format.eprintf "@[Rules:%a@]@." Omake_env.pp_print_explicit_rules venv (************************************************************************ * Dependencies. *) let compile_deps venv node buf = let deps = Omake_ast_lex.parse_deps buf in let vars = Omake_env.venv_include_scope venv IncludePervasives in let senv_empty = Omake_ir_ast.penv_of_vars (open_ir venv) venv node vars in List.map (fun (target, source, loc) -> let pos = string_pos "compile_deps" (loc_exp_pos loc) in let _, target = Omake_ir_ast.build_string senv_empty target pos in let _, source = Omake_ir_ast.build_string senv_empty source pos in let target = eval_string_exp venv pos target in let source = eval_string_exp venv pos source in let targets = strings_of_value venv pos target in let sources = strings_of_value venv pos source in targets, sources) deps omake-0.10.3/src/eval/omake_value.ml0000644000175000017500000003255513177364665015707 0ustar gerdgerd include Omake_pos.Make (struct let name = "Omake_value" end) (* * Get some functions from the evaluator. *) let eval_value = Omake_eval.eval_value let eval_single_value = Omake_eval.eval_single_value let eval_prim_value = Omake_eval.eval_prim_value (* * These functions fail on arrays. *) let string_of_value = Omake_eval.string_of_value (* * These functions are safe. *) let values_of_value = Omake_eval.values_of_value let strings_of_value = Omake_eval.strings_of_value let bool_of_value = Omake_eval.bool_of_value (* * Get the $value field of the object. *) let eval_object_value _ pos obj = let pos = string_pos "eval_object_value" pos in try Omake_env.venv_find_field_internal_exn obj Omake_symbol.builtin_sym with Not_found -> raise (Omake_value_type.OmakeException (pos, StringError "not a primitive object")) let add_object_value obj x = Omake_env.venv_add_field_internal obj Omake_symbol.builtin_sym x (* * Concatenate. *) let concat_array (xs : Omake_value_type.t list) : Omake_value_type.t = match xs with | [ValWhite s] | [ValString s] -> ValData s | [ValSequence _] as vl -> ValQuote vl | [v] -> v | vl -> ValArray vl let concat_strings xs : Omake_value_type.t = match xs with | [s] -> ValData s | sl -> ValArray (List.map (fun s -> Omake_value_type.ValData s) sl) (************************************************************************ * Conversions. *) (* * Numbers. *) let int_of_value venv pos v = match eval_prim_value venv pos v with ValInt i | ValOther (ValExitCode i) -> i | ValFloat x -> int_of_float x | v -> let s = string_of_value venv pos v in try int_of_string s with Failure _ -> raise (Omake_value_type.OmakeException (pos, StringStringError ("not an integer", s))) let float_of_value venv pos v = match eval_prim_value venv pos v with ValInt i | ValOther (ValExitCode i) -> float_of_int i | ValFloat x -> x | v -> let s = string_of_value venv pos v in try float_of_string s with Failure _ -> raise (Omake_value_type.OmakeException (pos, StringStringError ("not a floating-point number", s))) let number_of_value venv pos v = let v = eval_prim_value venv pos v in match v with ValInt _ | ValFloat _ -> v | ValOther (ValExitCode i) -> ValInt i | _ -> let s = string_of_value venv pos v in try ValInt (int_of_string s) with Failure _ -> try ValFloat (float_of_string s) with Failure _ -> raise (Omake_value_type.OmakeException (pos, StringStringError ("not a number", s))) (* * Variables. *) let var_of_value venv pos v = let v = eval_prim_value venv pos v in match v with ValVar (_, v) -> v | _ -> raise (Omake_value_type.OmakeException (pos, StringValueError ("not a var", v))) let vars_of_value venv pos v = List.map (var_of_value venv pos) (values_of_value venv pos v) (* * Maps. *) let map_of_value venv pos v = match eval_prim_value venv pos v with ValMap map -> map | v -> raise (Omake_value_type.OmakeException (pos, StringValueError ("not a map", v))) (* * Values that can be used as keys. *) let rec key_of_value venv pos v = let pos = string_pos "key_of_value" pos in let v = eval_prim_value venv pos v in match v with ValNone | ValDir _ | ValNode _ | ValData _ | ValInt _ | ValFloat _ | ValOther (ValExitCode _) | ValOther (ValLocation _) | ValVar _ -> v | ValQuote _ | ValQuoteString _ | ValWhite _ | ValString _ | ValSequence _ -> ValData (string_of_value venv pos v) | ValArray _ -> let values = values_of_value venv pos v in let values = List.map (key_of_value venv pos) values in ValArray values | ValMaybeApply _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValStringExp _ | ValBody _ | ValMap _ | ValObject _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValDelayed _ -> raise (Omake_value_type.OmakeException (pos, StringValueError ("bad map key", v))) (* * Files and directories. *) let file_of_value = Omake_eval.file_of_value let dir_of_value venv pos dir = let pos = string_pos "dir_of_value" pos in let dir = eval_prim_value venv pos dir in match dir with ValDir dir -> dir | ValNode _ | ValData _ | ValQuote _ | ValQuoteString _ | ValString _ | ValSequence _ | ValArray _ | ValInt _ | ValFloat _ -> Omake_env.venv_intern_dir venv (string_of_value venv pos dir) | ValNone | ValWhite _ | ValVar _ | ValMaybeApply _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValStringExp _ | ValBody _ | ValMap _ | ValObject _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValDelayed _ -> raise (Omake_value_type.OmakeException (pos, StringError "not a directory")) let node_value_of_value venv pos ?(follow_symlinks=true) v = let pos = string_pos "node_value_of_value" pos in let arg = eval_prim_value venv pos v in match arg with ValNode _ | ValDir _ -> arg | ValData _ | ValQuote _ | ValQuoteString _ | ValString _ | ValSequence _ | ValArray _ | ValMaybeApply _ | ValStringExp _ | ValBody _ | ValInt _ | ValFloat _ -> let name = string_of_value venv pos v in let node = Omake_env.venv_intern venv PhonyExplicit name in let cache = Omake_env.venv_cache venv in if Omake_cache.is_dir cache ~follow_symlinks node then ValDir (Omake_env.venv_intern_dir venv name) else ValNode node | ValNone | ValWhite _ | ValVar _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValMap _ | ValObject _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValDelayed _ -> raise (Omake_value_type.OmakeException (pos, StringValueError("not a file", v))) let dir_value_of_value venv pos v = let pos = string_pos "dir_value_of_value" pos in let arg = eval_prim_value venv pos v in match arg with ValNode _ | ValDir _ -> arg | ValData _ | ValQuote _ | ValQuoteString _ | ValString _ | ValSequence _ | ValArray _ | ValMaybeApply _ | ValStringExp _ | ValBody _ | ValInt _ | ValFloat _ -> let name = string_of_value venv pos v in ValDir (Omake_env.venv_intern_dir venv name) | ValNone | ValWhite _ | ValVar _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValMap _ | ValObject _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValDelayed _ -> raise (Omake_value_type.OmakeException (pos, StringValueError("not a file", v))) let filename_of_value venv pos v = let pos = string_pos "filename_of_value" pos in let arg = eval_prim_value venv pos v in match arg with ValNode node -> Omake_node.Node.fullname node | ValDir dir -> Omake_node.Dir.fullname dir | _ -> Omake_node.Node.fullname (file_of_value venv pos v) (* * Channels. The string & represents channels. *) let prim_channel_of_string venv pos s = let pos = string_pos "channel_of_string" pos in if s <> "" && s.[0] = '&' then let id = try int_of_string (String.sub s 1 (String.length s - 1)) with Failure _ -> raise (Omake_value_type.OmakeException (pos, StringStringError ("not a channel string", s))) in Omake_env.venv_find_channel_by_id venv pos id else raise (Omake_value_type.OmakeException (pos, StringStringError ("not a channel string", s))) (* let channel_of_string venv pos s = *) (* Omake_env.venv_find_channel venv pos (prim_channel_of_string venv pos s) *) let rec is_int_string s i len = if i = len then true else match s.[i] with '0'..'9' -> is_int_string s (succ i) len | _ -> false let is_channel_string s = s <> "" && s.[0] = '&' && is_int_string s 1 (String.length s) let prim_channel_of_value venv pos v = let pos = string_pos "prim_channel_of_value" pos in let arg = eval_prim_value venv pos v in match arg with ValChannel (_, channel) -> channel | ValNode _ | ValDir _ | ValData _ | ValQuote _ | ValQuoteString _ | ValString _ | ValSequence _ -> prim_channel_of_string venv pos (string_of_value venv pos arg) | ValInt _ | ValFloat _ | ValMaybeApply _ | ValVar _ | ValStringExp _ | ValBody _ | ValNone | ValWhite _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValArray _ | ValRules _ | ValMap _ | ValObject _ | ValClass _ | ValCases _ | ValOther _ | ValDelayed _ -> raise (Omake_value_type.OmakeException (pos, StringError "not a channel")) let prim_channel_of_var venv pos loc v = prim_channel_of_value venv pos (Omake_env.venv_find_var venv pos loc v) let channel_of_var venv pos loc v = let channel = prim_channel_of_var venv pos loc v in Omake_env.venv_find_channel venv pos channel let channel_of_value venv pos v = let pos = string_pos "channel_of_value" pos in let channel = prim_channel_of_value venv pos v in Omake_env.venv_find_channel venv pos channel let in_channel_of_any_value venv pos v = let pos = string_pos "in_channel_of_any_value" pos in let arg = eval_prim_value venv pos v in match arg with ValChannel (InChannel, p) | ValChannel (InOutChannel, p) -> p, false | ValNode _ | ValDir _ | ValData _ | ValQuote _ | ValQuoteString _ | ValString _ | ValSequence _ | ValMaybeApply _ | ValStringExp _ | ValBody _ | ValInt _ | ValFloat _ -> let s = string_of_value venv pos arg in if is_channel_string s then prim_channel_of_string venv pos s, false else let node = Omake_env.venv_intern venv PhonyProhibited s in let name = Omake_node.Node.fullname node in let fd = try Lm_unix_util.openfile name [Unix.O_RDONLY] 0 with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in let chan = Lm_channel.create name Lm_channel.FileChannel Lm_channel.InChannel false (Some fd) in let pc = Omake_env.venv_add_channel venv chan in pc, true | ValChannel (OutChannel, _) | ValNone | ValWhite _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValArray _ | ValRules _ | ValMap _ | ValObject _ | ValClass _ | ValCases _ | ValOther _ | ValVar _ | ValDelayed _ -> raise (Omake_value_type.OmakeException (pos, StringError "not an input channel")) let out_channel_of_any_value venv pos v = let pos = string_pos "out_channel_of_any_value" pos in let arg = eval_prim_value venv pos v in match arg with ValChannel (OutChannel, p) | ValChannel (InOutChannel, p) -> p, false | ValNode _ | ValDir _ | ValData _ | ValQuote _ | ValString _ | ValQuoteString _ | ValSequence _ | ValMaybeApply _ | ValStringExp _ | ValBody _ | ValInt _ | ValFloat _ -> let s = string_of_value venv pos arg in if is_channel_string s then prim_channel_of_string venv pos s, false else let node = Omake_env.venv_intern venv PhonyProhibited s in let name = Omake_node.Node.fullname node in let fd = try Lm_unix_util.openfile name [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 0o666 with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in let chan = Lm_channel.create name Lm_channel.FileChannel Lm_channel.OutChannel false (Some fd) in let prim = Omake_env.venv_add_channel venv chan in prim, true | ValChannel (InChannel, _) | ValNone | ValWhite _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValArray _ | ValRules _ | ValMap _ | ValObject _ | ValClass _ | ValCases _ | ValOther _ | ValVar _ | ValDelayed _ -> raise (Omake_value_type.OmakeException (pos, StringError "not an output channel")) (* * Check whether the value has any glob characters in it. *) let rec is_glob_value options (v : Omake_value_type.t) = match v with | ValString s -> Lm_glob.is_glob_string options s | ValSequence vl | ValArray vl -> is_glob_value_list options vl | ValQuoteString _ | ValChannel _ | ValNode _ | ValDir _ | ValData _ | ValQuote _ | ValMaybeApply _ | ValStringExp _ | ValBody _ | ValInt _ | ValFloat _ | ValNone | ValWhite _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValRules _ | ValMap _ | ValObject _ | ValClass _ | ValCases _ | ValOther _ | ValVar _ | ValDelayed _ -> false and is_glob_value_list options vl = List.exists (is_glob_value options) vl (* * Lexing and parsing. *) let current_lexer venv pos = let pos = string_pos "current_lexer" pos in try match Omake_env.venv_find_var_exn venv Omake_var.builtin_field_var with ValOther (ValLexer lexer) -> lexer | v -> raise (Omake_value_type.OmakeException (pos, StringValueError ("not a lexer", v))) with Not_found -> Omake_lexer.Lexer.empty let current_parser venv pos = let pos = string_pos "current_parser" pos in try match Omake_env.venv_find_var_exn venv Omake_var.builtin_field_var with ValOther (ValParser parser) -> parser | v -> raise (Omake_value_type.OmakeException (pos, StringValueError ("not a parser", v))) with Not_found -> Omake_parser.Parser.empty let loc_of_value venv pos v = match eval_prim_value venv pos v with ValOther (ValLocation loc) -> loc | _ -> raise (Omake_value_type.OmakeException (pos, StringValueError ("not a location", v))) omake-0.10.3/src/eval/omake_eval.mli0000644000175000017500000001443013177364666015664 0ustar gerdgerd(* * Compile (evaluate) an OMakefile. *) val print_ast : bool ref val print_ir : bool ref val print_rules : bool ref val print_files : bool ref val debug_eval : bool ref val raise_uncaught_exception : Omake_value_type.pos -> exn -> 'a (* * Evaluate an expression. *) val eval : Omake_env.t -> Omake_ir.exp -> Omake_value_type.t val eval_exp : Omake_env.t -> Omake_value_type.t -> Omake_ir.exp -> Omake_env.t * Omake_value_type.t val eval_sequence : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_ir.exp list -> Omake_env.t * Omake_value_type.t val eval_sequence_export : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_ir.exp list -> Omake_ir.export -> Omake_env.t * Omake_value_type.t val eval_sequence_exp : Omake_env.t -> Omake_value_type.pos -> Omake_ir.exp list -> Omake_env.t * Omake_value_type.t val eval_sequence_export_exp : Omake_env.t -> Omake_value_type.pos -> Omake_ir.exp list -> Omake_ir.export -> Omake_env.t * Omake_value_type.t (* * String expression evaluation. *) val eval_string_exp : Omake_env.t -> Omake_value_type.pos -> Omake_ir.string_exp -> Omake_value_type.t (* * Include the file literally. *) val find_include_file : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> string -> Omake_node.Node.t val eval_open_file : Omake_env.t -> Omake_ir_ast.senv_open_file val eval_include_file : Omake_env.t -> Omake_env.include_scope -> Omake_value_type.pos -> Lm_location.t -> Omake_node.Node.t -> Omake_env.t * Omake_value_type.t val include_file : Omake_env.t -> Omake_env.include_scope -> Omake_value_type.pos -> Lm_location.t -> Omake_node.Node.t -> Omake_env.t (* * Evaluate a file as if it were an object. *) val eval_object_file : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_node.Node.t -> Omake_value_type.obj (* * Evaluate the program. * This modifies the environment. *) val compile : Omake_env.t -> unit (* * Passes the IR thru Omake_ir_semant.build_prog, printing it if print_ir is enabled. *) val postprocess_ir : Omake_env.t -> Omake_ir.t -> Omake_ir.t (* * Evaluate a dependency file. *) val compile_deps : Omake_env.t -> Omake_node.Node.t -> string -> (string list * string list) list (* * Remove outermost applications. * GS: Force lazy applications! *) val eval_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t (* * Evaluate ValBody expressions. *) val eval_body_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t val eval_body_exp : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t -> Omake_env.t * Omake_value_type.t (* * Get the object for the Omake_value_type.t. *) val eval_object : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.obj val eval_find_field : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_ir.var_info -> Omake_ir.var list -> Omake_value_type.path * Omake_value_type.obj * Omake_ir.var val eval_find_method : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_ir.var_info -> Omake_ir.var list -> Omake_env.t * Omake_value_type.t val eval_defined_field : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_ir.var_info -> Omake_ir.var list -> bool (* * Evaluate a Omake_value_type.t that should be a function. If [caller_env] * is set, extract the static evironment from the first arg so far the value is * a body. Otherwise (the default), the static environment is taken from the * definition site of the function. * * Be careful with this: don't create a ValPrim using * this function, since marshaling will fail. *) val eval_fun : ?caller_env:bool -> Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> bool * Omake_env.prim_fun_data (* Companion for [eval_fun]: Get the static environment from the definition * of the function (or, in the case of primitives, from the call site). *) val definition_env_of_fun : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.env (* * Also, if the Omake_value_type.t is an array of 1 element, * return the element. *) val eval_single_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t (* * Evaluate to a primitive Omake_value_type.t. * That is, if the Omake_value_type.t is an object, return the * primitive handle associated with the object. * If the object has no primitive Omake_value_type.t, the object * itself is returned. *) val eval_prim_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t (* * Evaluate a function application. *) val eval_apply : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_value_type.t -> Omake_value_type.t list -> Omake_value_type.keyword_value list -> Omake_env.t * Omake_value_type.t val eval_partial_apply : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_value_type.t -> Omake_value_type.t list -> Omake_value_type.keyword_value list -> Omake_env.t * Omake_value_type.t (* * Conversions. * The following two functions should be used with care, since * they fail if the Omake_value_type.t contains an array. *) val string_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> string val string_of_quote : Omake_env.t -> Omake_value_type.pos -> char option -> Omake_value_type.t list -> string val file_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_node.Node.t val path_of_values : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t list -> string -> (bool * Omake_node.Dir.t list) list (* * These conversions are safe to use anywhere. *) val tokens_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_env.lexer -> Omake_value_type.t -> Omake_env.tok list val arg_of_values : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t list -> Omake_command_type.arg val argv_of_values : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t list list -> Omake_command_type.arg list val values_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t list val strings_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> string list val bool_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> bool omake-0.10.3/src/eval/omake_value.mli0000644000175000017500000000712613177364666016055 0ustar gerdgerd(** If there is only one value, do not create the array. *) val concat_array : Omake_value_type.t list -> Omake_value_type.t (* * Concatenate some strings. * If there is only 1 value, do not create the array. *) val concat_strings : string list -> Omake_value_type.t (* * Expand a value so that the outermost constructor * is not an application. *) val eval_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t val eval_single_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t val eval_prim_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t val eval_object_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.obj -> Omake_value_type.t val add_object_value : Omake_value_type.obj -> Omake_value_type.t -> Omake_value_type.obj (* * Convert to a string. *) val string_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> string val strings_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> string list val values_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t list val vars_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_ir.var_info list (* * Coercions. *) val bool_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> bool val int_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> int val float_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> float val number_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t val key_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t val map_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.map val dir_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_node.Dir.t val file_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_node.Node.t val node_value_of_value : Omake_env.t -> Omake_value_type.pos -> ?follow_symlinks:bool -> Omake_value_type.t -> Omake_value_type.t val dir_value_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t val filename_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> string val prim_channel_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.prim_channel val prim_channel_of_var : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_ir.var_info -> Omake_value_type.prim_channel val channel_of_var : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_ir.var_info -> Lm_channel.t val channel_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Lm_channel.t val in_channel_of_any_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.prim_channel * bool val out_channel_of_any_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.prim_channel * bool val is_glob_value : Lm_glob.glob_options -> Omake_value_type.t -> bool val is_glob_value_list : Lm_glob.glob_options -> Omake_value_type.t list -> bool val current_lexer : Omake_env.t -> Omake_value_type.pos -> Omake_lexer.Lexer.t val current_parser : Omake_env.t -> Omake_value_type.pos -> Omake_parser.Parser.t val loc_of_value : Omake_env.t -> Omake_value_type.pos -> Omake_value_type.t -> Lm_location.t omake-0.10.3/src/shell/0000755000175000017500000000000013177364666013234 5ustar gerdgerdomake-0.10.3/src/shell/OMakefile0000644000175000017500000000202113177364665015005 0ustar gerdgerdOCAMLINCLUDES[] += ../libmojave ../front ../ast ../ir ../env ../eval FILES[] = omake_shell_parse omake_shell_lex omake_shell_spawn omake_shell_sys_type omake_shell_sys omake_shell_job omake_shell_completion MakeOCamlLibrary(shell, $(FILES)) GENERATED_FILES[] = omake_shell_parse.mli omake_shell_parse.ml omake_shell_sys.ml OCamlGeneratedFiles($(GENERATED_FILES)) OMAKE_SHELL_SYS = omake_shell_sys_$(if $(equal $(OSTYPE), Win32), win32, unix).ml omake_shell_sys.ml: $(OMAKE_SHELL_SYS) ln-or-cp $< $@ clean: $(CLEAN) $(GENERATED_FILES) ######################################################################## # Generate a Makefile # win32 = $'$(win32)' MAKEFILE_TEXT += $""" omake_shell_parse.ml: omake_shell_parse.mly omake_shell_parse.mli: omake_shell_parse.mly omake_shell_parse.cmo: omake_shell_parse.cmi """ MakeLinkFiles(omake_shell_parse.mly) MakeLinkFile(omake_shell_sys.ml, omake_shell_sys_$(win32).ml) MakeDontLink($(GENERATED_FILES)) MakeMakefile() omake-0.10.3/src/shell/omake_shell_spawn.ml0000644000175000017500000000613413177364665017264 0ustar gerdgerd(* This is the module for subprocess execution derived from OCamlnet. It is only meant for Unix. If available, it takes advantage from the posix_spawn call. Copyright (C) 2014 by Gerd Stolpmann This file is licensed under the same conditions as omake. This work was sponsored by Lexifi. *) (* Wrapping the library function *) type wd_spec = | Wd_keep | Wd_chdir of string | Wd_fchdir of Unix.file_descr type pg_spec = | Pg_keep | Pg_new_bg_group | Pg_new_fg_group | Pg_join_group of int type fd_action = | Fda_close of Unix.file_descr | Fda_close_ignore of Unix.file_descr | Fda_close_except of bool array | Fda_dup2 of Unix.file_descr * Unix.file_descr type sig_action = | Sig_default of int | Sig_ignore of int | Sig_mask of int list external compat_spawn : wd_spec -> pg_spec -> fd_action list -> sig_action list -> string array -> string -> string array -> int = "omake_shell_spawn_compat_byte" "omake_shell_spawn_compat_nat" external posix_spawn : pg_spec -> fd_action list -> sig_action list -> string array -> string -> string array -> int = "omake_shell_spawn_posix_byte" "omake_shell_spawn_posix_nat" external have_posix_spawn : unit -> bool = "omake_shell_spawn_have_posix_spawn" external fchdir : Unix.file_descr -> unit = "omake_shell_spawn_fchdir" let spawn ?(chdir = Wd_keep) ?(pg = Pg_keep) ?(fd_actions = []) ?(sig_actions = []) ?(env = Unix.environment()) ?(no_posix_spawn=false) cmd args = ( (* Check whether we can use the faster posix_spawn *) let use_posix_spawn = not no_posix_spawn && have_posix_spawn() && pg <> Pg_new_fg_group && not (List.exists (fun sa -> match sa with Sig_ignore _ -> true | _ -> false) sig_actions) in try if not use_posix_spawn then failwith "USE_FORK_EXEC"; (* emulate chdir. We are single-threaded, so this is easy: *) let cur_dir = Unix.openfile "." [ Unix.O_RDONLY] 0 in let change_back() = fchdir cur_dir; Unix.close cur_dir in ( try ( match chdir with | Wd_keep -> () | Wd_chdir file -> Unix.chdir file | Wd_fchdir fd -> fchdir fd ); let pid = posix_spawn pg fd_actions sig_actions env cmd args in (* may also fail with "USE_FORK_EXEC" in some cases *) change_back(); pid with | error -> change_back(); raise error ) with | Failure "USE_FORK_EXEC" -> (* Fixup: if pg = Pg_new_fg_group, we remove any Sig_default for SIGTTOU from sig_actions. Because of special handling, the effect of Sig_default is enforced by the implementation, but this must be done at [execve] time. *) let sig_actions = if pg = Pg_new_fg_group then List.filter (fun spec -> spec <> Sig_default Sys.sigttou) sig_actions else sig_actions in compat_spawn chdir pg fd_actions sig_actions env cmd args )[@ocaml.warning "-52"] omake-0.10.3/src/shell/omake_shell_parse.ml0000644000175000017500000004206513177364665017251 0ustar gerdgerdtype token = | TokEof of (Lm_location.t) | TokValues of (Omake_value_type.t list * Lm_location.t) | TokDefine of (string * Lm_location.t) | TokLeftParen of (string * Lm_location.t) | TokRightParen of (string * Lm_location.t) | TokLessThan of (string * Lm_location.t) | TokGreaterThan of (string * Lm_location.t) | TokGreaterGreaterThan of (string * Lm_location.t) | TokAmp of (string * Lm_location.t) | TokPipe of (string * Lm_location.t) | TokSemiColon of (string * Lm_location.t) | TokAnd of (string * Lm_location.t) | TokOr of (string * Lm_location.t) open Parsing;; let _ = parse_error;; # 30 "omake_shell_parse.mly" open Lm_location open Omake_shell_type open Omake_value_type module Pos = Omake_pos.Make (struct let name = "Omake_shell_parse" end) (* * If the command is a node, detect it here. *) let collect_redirect chan = match chan with [ValNode node] -> RedirectNode node | _ -> RedirectArg chan (* * Build a command from a sequence of words. *) let null_command loc = { cmd_loc = loc; cmd_env = []; cmd_exe = (); cmd_argv = []; cmd_stdin = RedirectNone; cmd_stdout = RedirectNone; cmd_stderr = false; cmd_append = false } let command_of_values argv loc = { cmd_loc = loc; cmd_env = []; cmd_exe = (); cmd_argv = argv; cmd_stdin = RedirectNone; cmd_stdout = RedirectNone; cmd_stderr = false; cmd_append = false } (* * Diversions. *) let rec set_stdin_inner pipe file = match pipe with PipeApply (loc, apply) -> let apply = { apply with apply_stdin = file } in PipeApply (loc, apply) | PipeCommand (loc, command) -> let command = { command with cmd_stdin = file } in PipeCommand (loc, command) | PipeCond (_, _, _, _) | PipeCompose (_, _, _, _) -> raise (Invalid_argument "Omake_shell_parse.set_stdin: internal error") | PipeGroup (loc, group) -> let group = { group with group_stdin = file } in PipeGroup (loc, group) | PipeBackground (loc, pipe) -> PipeBackground (loc, set_stdin_inner pipe file) let rec set_stdout_inner pipe file stderr append = match pipe with PipeApply (loc, apply) -> let apply = { apply with apply_stdout = file; apply_stderr = stderr; apply_append = append } in PipeApply (loc, apply) | PipeCommand (loc, command) -> let command = { command with cmd_stdout = file; cmd_stderr = stderr; cmd_append = append } in PipeCommand (loc, command) | PipeCond (_, _, _, _) | PipeCompose (_, _, _, _) -> raise (Invalid_argument "Omake_shell_parse.set_stdout: internal error") | PipeGroup (loc, group) -> let group = { group with group_stdout = file; group_stderr = stderr; group_append = append } in PipeGroup (loc, group) | PipeBackground (loc, pipe) -> PipeBackground (loc, set_stdout_inner pipe file stderr append) let set_stdin pipe file = set_stdin_inner pipe (collect_redirect file) let set_stdout pipe file stderr append = set_stdout_inner pipe (collect_redirect file) stderr append # 125 "omake_shell_parse.ml" let yytransl_const = [| 0|] let yytransl_block = [| 257 (* TokEof *); 258 (* TokValues *); 259 (* TokDefine *); 260 (* TokLeftParen *); 261 (* TokRightParen *); 262 (* TokLessThan *); 263 (* TokGreaterThan *); 264 (* TokGreaterGreaterThan *); 265 (* TokAmp *); 266 (* TokPipe *); 267 (* TokSemiColon *); 268 (* TokAnd *); 269 (* TokOr *); 0|] let yylhs = "\255\255\ \001\000\001\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\003\000\ \005\000\005\000\004\000\000\000" let yylen = "\002\000\ \002\000\001\000\001\000\003\000\003\000\003\000\003\000\004\000\ \002\000\003\000\003\000\003\000\003\000\004\000\004\000\001\000\ \001\000\002\000\001\000\002\000" let yydefred = "\000\000\ \000\000\000\000\002\000\019\000\000\000\020\000\000\000\003\000\ \017\000\000\000\000\000\001\000\000\000\000\000\000\000\009\000\ \000\000\000\000\000\000\000\000\018\000\010\000\011\000\000\000\ \012\000\000\000\013\000\000\000\000\000\000\000\000\000\000\000\ \014\000\015\000\000\000" let yydgoto = "\002\000\ \006\000\007\000\008\000\009\000\010\000" let yysindex = "\008\000\ \033\255\000\000\000\000\000\000\017\255\000\000\032\255\000\000\ \000\000\020\255\071\255\000\000\020\255\002\255\008\255\000\000\ \255\254\017\255\017\255\017\255\000\000\000\000\000\000\020\255\ \000\000\020\255\000\000\017\255\096\255\088\255\080\255\104\255\ \000\000\000\000\096\255" let yyrindex = "\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\019\255\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\059\255\084\255\045\255\052\255\ \000\000\000\000\064\255" let yygindex = "\000\000\ \000\000\251\255\000\000\248\255\000\000" let yytablesize = 117 let yytable = "\011\000\ \004\000\021\000\005\000\004\000\023\000\025\000\027\000\028\000\ \001\000\004\000\024\000\029\000\030\000\031\000\032\000\033\000\ \026\000\034\000\004\000\016\000\005\000\004\000\035\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \012\000\003\000\004\000\000\000\005\000\013\000\014\000\015\000\ \016\000\017\000\018\000\019\000\020\000\005\000\000\000\000\000\ \000\000\005\000\000\000\000\000\006\000\005\000\005\000\005\000\ \006\000\005\000\000\000\007\000\006\000\006\000\006\000\007\000\ \008\000\000\000\000\000\007\000\008\000\007\000\000\000\000\000\ \008\000\000\000\008\000\022\000\013\000\014\000\015\000\016\000\ \017\000\018\000\019\000\020\000\004\000\013\000\014\000\015\000\ \004\000\000\000\000\000\019\000\004\000\013\000\014\000\015\000\ \000\000\017\000\018\000\019\000\020\000\013\000\014\000\015\000\ \000\000\017\000\000\000\019\000\020\000\013\000\014\000\015\000\ \000\000\000\000\000\000\019\000\020\000" let yycheck = "\005\000\ \002\001\010\000\004\001\002\001\013\000\014\000\015\000\009\001\ \001\000\002\001\009\001\017\000\018\000\019\000\020\000\024\000\ \009\001\026\000\002\001\001\001\004\001\002\001\028\000\005\001\ \006\001\007\001\008\001\009\001\010\001\011\001\012\001\013\001\ \001\001\001\001\002\001\255\255\004\001\006\001\007\001\008\001\ \009\001\010\001\011\001\012\001\013\001\001\001\255\255\255\255\ \255\255\005\001\255\255\255\255\001\001\009\001\010\001\011\001\ \005\001\013\001\255\255\001\001\009\001\010\001\011\001\005\001\ \001\001\255\255\255\255\009\001\005\001\011\001\255\255\255\255\ \009\001\255\255\011\001\005\001\006\001\007\001\008\001\009\001\ \010\001\011\001\012\001\013\001\001\001\006\001\007\001\008\001\ \005\001\255\255\255\255\012\001\009\001\006\001\007\001\008\001\ \255\255\010\001\011\001\012\001\013\001\006\001\007\001\008\001\ \255\255\010\001\255\255\012\001\013\001\006\001\007\001\008\001\ \255\255\255\255\255\255\012\001\013\001" let yynames_const = "\ " let yynames_block = "\ TokEof\000\ TokValues\000\ TokDefine\000\ TokLeftParen\000\ TokRightParen\000\ TokLessThan\000\ TokGreaterThan\000\ TokGreaterGreaterThan\000\ TokAmp\000\ TokPipe\000\ TokSemiColon\000\ TokAnd\000\ TokOr\000\ " let yyact = [| (fun _ -> failwith "parser") ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'pipe) in let _2 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 190 "omake_shell_parse.mly" ( let pipe, _ = _1 in pipe ) # 246 "omake_shell_parse.ml" : Omake_env.value_pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Lm_location.t) in Obj.repr( # 194 "omake_shell_parse.mly" ( let loc = _1 in PipeCommand (loc, null_command loc) ) # 255 "omake_shell_parse.ml" : Omake_env.value_pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'command) in Obj.repr( # 203 "omake_shell_parse.mly" ( let command, loc = _1 in PipeCommand (loc, command), loc ) # 264 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pipe) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pipe) in Obj.repr( # 207 "omake_shell_parse.mly" ( let pipe1, loc1 = _1 in let pipe2, loc2 = _3 in let loc = union_loc loc1 loc2 in PipeCond (loc, PipeSequence, pipe1, pipe2), loc ) # 277 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pipe) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pipe) in Obj.repr( # 213 "omake_shell_parse.mly" ( let pipe1, loc1 = _1 in let pipe2, loc2 = _3 in let loc = union_loc loc1 loc2 in PipeCond (loc, PipeAnd, pipe1, pipe2), loc ) # 290 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pipe) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pipe) in Obj.repr( # 219 "omake_shell_parse.mly" ( let pipe1, loc1 = _1 in let pipe2, loc2 = _3 in let loc = union_loc loc1 loc2 in PipeCond (loc, PipeOr, pipe1, pipe2), loc ) # 303 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pipe) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pipe) in Obj.repr( # 225 "omake_shell_parse.mly" ( let pipe1, loc1 = _1 in let pipe2, loc2 = _3 in let loc = union_loc loc1 loc2 in PipeCompose (loc, false, pipe1, pipe2), loc ) # 316 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'pipe) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _4 = (Parsing.peek_val __caml_parser_env 0 : 'pipe) in Obj.repr( # 231 "omake_shell_parse.mly" ( let pipe1, loc1 = _1 in let pipe2, loc2 = _4 in let loc = union_loc loc1 loc2 in PipeCompose (loc, true, pipe1, pipe2), loc ) # 330 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'pipe) in let _2 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 237 "omake_shell_parse.mly" ( let pipe, loc1 = _1 in let _, loc2 = _2 in let loc = union_loc loc1 loc2 in PipeBackground (loc, pipe), loc ) # 342 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pipe) in let _3 = (Parsing.peek_val __caml_parser_env 0 : string * Lm_location.t) in Obj.repr( # 243 "omake_shell_parse.mly" ( let _, loc1 = _1 in let _, loc2 = _3 in let loc = union_loc loc1 loc2 in let pipe, _ = _2 in let group = { group_stdin = RedirectNone; group_stdout = RedirectNone; group_stderr = false; group_append = false; group_pipe = pipe } in PipeGroup (loc, group), loc ) # 364 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pipe) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'word) in Obj.repr( # 258 "omake_shell_parse.mly" ( let pipe, loc1 = _1 in let file, loc2 = _3 in let loc = union_loc loc1 loc2 in let pipe = set_stdin pipe file in pipe, loc ) # 378 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pipe) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'word) in Obj.repr( # 265 "omake_shell_parse.mly" ( let pipe, loc1 = _1 in let file, loc2 = _3 in let loc = union_loc loc1 loc2 in let pipe = set_stdout pipe file false false in pipe, loc ) # 392 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pipe) in let _2 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'word) in Obj.repr( # 272 "omake_shell_parse.mly" ( let pipe, loc1 = _1 in let file, loc2 = _3 in let loc = union_loc loc1 loc2 in let pipe = set_stdout pipe file false true in pipe, loc ) # 406 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'pipe) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _4 = (Parsing.peek_val __caml_parser_env 0 : 'word) in Obj.repr( # 279 "omake_shell_parse.mly" ( let pipe, loc1 = _1 in let file, loc2 = _4 in let loc = union_loc loc1 loc2 in let pipe = set_stdout pipe file true false in pipe, loc ) # 421 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'pipe) in let _2 = (Parsing.peek_val __caml_parser_env 2 : string * Lm_location.t) in let _3 = (Parsing.peek_val __caml_parser_env 1 : string * Lm_location.t) in let _4 = (Parsing.peek_val __caml_parser_env 0 : 'word) in Obj.repr( # 286 "omake_shell_parse.mly" ( let pipe, loc1 = _1 in let file, loc2 = _4 in let loc = union_loc loc1 loc2 in let pipe = set_stdout pipe file true true in pipe, loc ) # 436 "omake_shell_parse.ml" : 'pipe)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rev_command) in Obj.repr( # 298 "omake_shell_parse.mly" ( let rev_argv, loc = _1 in let command = command_of_values (List.rev rev_argv) loc in command, loc ) # 446 "omake_shell_parse.ml" : 'command)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'word) in Obj.repr( # 306 "omake_shell_parse.mly" ( let values, loc = _1 in [values], loc ) # 455 "omake_shell_parse.ml" : 'rev_command)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rev_command) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'word) in Obj.repr( # 310 "omake_shell_parse.mly" ( let values1, loc1 = _1 in let values2, loc2 = _2 in values2 :: values1, union_loc loc1 loc2 ) # 466 "omake_shell_parse.ml" : 'rev_command)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Omake_value_type.t list * Lm_location.t) in Obj.repr( # 320 "omake_shell_parse.mly" ( _1 ) # 473 "omake_shell_parse.ml" : 'word)) (* Entry prog *) ; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) |] let yytables = { Parsing.actions=yyact; Parsing.transl_const=yytransl_const; Parsing.transl_block=yytransl_block; Parsing.lhs=yylhs; Parsing.len=yylen; Parsing.defred=yydefred; Parsing.dgoto=yydgoto; Parsing.sindex=yysindex; Parsing.rindex=yyrindex; Parsing.gindex=yygindex; Parsing.tablesize=yytablesize; Parsing.table=yytable; Parsing.check=yycheck; Parsing.error_function=parse_error; Parsing.names_const=yynames_const; Parsing.names_block=yynames_block } let prog (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = (Parsing.yyparse yytables 1 lexfun lexbuf : Omake_env.value_pipe) omake-0.10.3/src/shell/omake_shell_lex.ml0000644000175000017500000002626313177364665016731 0ustar gerdgerd(* * A token-preserving lexer for the shell. *) open Lm_printf open Omake_env open Omake_eval open Omake_value_type open Omake_shell_type open Omake_shell_parse open Omake_value_print open Omake_command_type module Pos = Omake_pos.Make (struct let name = "Omake_shell_lex" end);; open Pos;; (************************************************************************ * Lexing. *) (* * Locations. *) (* let shell_sym = Lm_symbol.add "shell" *) let syntax_error s loc = raise (OmakeException (loc_exp_pos loc, SyntaxError s)) (* * For debugging, try to print the first token. *) let rec pp_print_token buf tok = match tok with Omake_env.TokString v -> pp_print_value buf v | Omake_env.TokToken s -> pp_print_string buf s | Omake_env.TokGroup toks -> fprintf buf "(%a)" pp_print_token_list toks and pp_print_token_list buf toks = match toks with [tok] -> pp_print_token buf tok | tok :: toks -> pp_print_token buf tok; pp_print_char buf ' '; pp_print_token_list buf toks | [] -> () (* * Tokenizer. *) let flatten_items items loc = let rec collect tokens vl vll = match vl, vll with v :: vl, _ -> (match v with Omake_env.TokGroup vl' -> collect tokens vl' (vl :: vll) | Omake_env.TokString v -> collect (v :: tokens) vl vll | Omake_env.TokToken s -> syntax_error ("illegal token: " ^ s) loc) | [], vl :: vll -> collect tokens vl vll | [], [] -> List.rev tokens in collect [] items [] let lex_tok token loc = match token with Omake_env.TokToken s -> (match s with "<" -> TokLessThan (s, loc) | ">" -> TokGreaterThan (s, loc) | ">>" -> TokGreaterGreaterThan (s, loc) | "&" -> TokAmp (s, loc) | ";" -> TokSemiColon (s, loc) | "&&" -> TokAnd (s, loc) | "|" -> TokPipe (s, loc) | "||" -> TokOr (s, loc) | "(" -> TokLeftParen (s, loc) | ")" -> TokRightParen (s, loc) | _ -> syntax_error ("illegal operator: " ^ s) loc) | Omake_env.TokGroup items -> TokValues (flatten_items items loc, loc) | Omake_env.TokString v -> TokValues ([v], loc) (* * Token buffer. *) type lexinfo = { mutable lex_tokens : Omake_env.tok list; mutable lex_pos : int; lex_loc : Lm_location.t } let create_lexinfo loc tokens = { lex_tokens = tokens; lex_pos = 1; lex_loc = loc } let lex_main lexinfo _lexbuf = let { lex_tokens = tokens; lex_pos = pos; lex_loc = loc } = lexinfo in match tokens with [] -> TokEof loc | token :: tokens -> let tok = lex_tok token loc in lexinfo.lex_tokens <- tokens; lexinfo.lex_pos <- pos + 1; tok (* * Lexer from a token list. *) let lexbuf = Lexing.from_string "dummy lexbuf" let parse loc tokens = let lexinfo = create_lexinfo loc tokens in try Omake_shell_parse.prog (lex_main lexinfo) lexbuf with Parsing.Parse_error -> syntax_error "parse error" loc (************************************************************************ * Token lexer. *) let check_next c s off len = let off = succ off in if off < len && s.[off] = c then 2 else 1 let lexer s off len = match s.[off] with '<' | '(' | ')' | ';' -> Some 1 | '&' -> Some (check_next '&' s off len) | '|' -> Some (check_next '|' s off len) | '>' -> Some (check_next '>' s off len) | _ -> None (************************************************************************ * Strip the initial flags. *) let collect_flags toks = let rec collect_flags flags toks = if false then eprintf "Command: %a@." pp_print_token_list toks; match toks with tok :: toks' -> (match tok with TokString (ValString s) -> let len = String.length s in let rec scan flags i = if i = len then collect_flags flags toks' else match s.[i] with '@' -> scan (QuietFlag :: flags) (succ i) | '-' -> scan (AllowFailureFlag :: flags) (succ i) | '+' -> scan flags (succ i) | _ -> let toks = if succ i = len then toks' else TokString (ValString (String.sub s i (len - i))) :: toks' in flags, toks in scan flags 0 | _ -> flags, toks) | [] -> flags, toks in collect_flags [] toks (************************************************************************ * Command-line parsing. *) let rec flatten_value v = match v with ValArray [v] | ValSequence [v] -> flatten_value v | v -> v let flatten_values vl = match vl with [v] -> [flatten_value v] | _ -> vl let arg_of_redirect venv pos v = match v with RedirectArg v -> (match flatten_values v with [ValNode node] -> RedirectNode node | v -> RedirectArg (arg_of_values venv pos v)) | RedirectNode _ | RedirectNone as v -> v (* * When parsing the command line, collect all environment definitions. *) let scan_define arg = match arg with ArgString s :: args -> (try let i = String.index s '=' in let v = Lm_symbol.add (String.sub s 0 i) in let i = succ i in let len = String.length s in let args = if i = len then args else ArgString (String.sub s i (len - i)) :: args in Some (v, args) with Not_found -> None) | _ -> None (* * For a command, scan forward, collecting the env. *) let rec scan_argv venv pos env argv = match argv with arg :: argv -> (match flatten_values arg with [ValNode node] -> env, CmdNode node, argv | v -> let arg = arg_of_values venv pos v in (match scan_define arg with Some (v, s) -> scan_argv venv pos ((v, s) :: env) argv | None -> env, CmdArg arg, argv)) | [] -> raise (OmakeException (pos, NullCommand)) (* * A pipe might actually refer to an alias. *) let pre_pipe_command venv find_alias options pos info = let { cmd_loc = loc; cmd_argv = argv; cmd_stdin = stdin; cmd_stdout = stdout; cmd_stderr = stderr; cmd_append = append; _ } = info in let stdin = arg_of_redirect venv pos stdin in let stdout = arg_of_redirect venv pos stdout in (* Scan the argument list *) let env, exe, argv = scan_argv venv pos [] argv in let env = List.rev env in (* Detect whether this is an alias *) let f = match exe with CmdNode _ -> None | CmdArg arg -> if is_quoted_arg arg || is_glob_arg options arg then None else let s = simple_string_of_arg arg in find_alias venv pos loc s in match f with Some (name, f) -> (* This is an alias *) let apply = { apply_loc = loc; apply_env = env; apply_name = name; apply_fun = f; apply_args = List.map (fun vl -> ValSequence vl) argv; apply_stdin = stdin; apply_stdout = stdout; apply_stderr = stderr; apply_append = append } in PipeApply (loc, apply) | None -> (* This is a normal command *) let command = { info with cmd_env = env; cmd_exe = exe; cmd_argv = argv_of_values venv pos argv; cmd_stdin = stdin; cmd_stdout = stdout } in PipeCommand (loc, command) (* * The parser never produces aliases, * so this code is dead. *) let pre_pipe_apply venv pos info = let { apply_env = env; apply_args = args; apply_stdin = stdin; apply_stdout = stdout; _ } = info in { info with apply_env = List.map (fun (x, v) -> x, arg_of_values venv pos v) env; apply_args = List.map (fun vl -> ValSequence vl) args; apply_stdin = arg_of_redirect venv pos stdin; apply_stdout = arg_of_redirect venv pos stdout } (* * Parse all the components of the pipe. *) let rec pre_pipe venv find_alias options pos pipe = match pipe with PipeApply (loc, info) -> PipeApply (loc, pre_pipe_apply venv pos info) | PipeCommand (_, info) -> pre_pipe_command venv find_alias options pos info | PipeCond (loc, op, pipe1, pipe2) -> PipeCond (loc, op, pre_pipe venv find_alias options pos pipe1, pre_pipe venv find_alias options pos pipe2) | PipeCompose (loc, b, pipe1, pipe2) -> PipeCompose (loc, b, pre_pipe venv find_alias options pos pipe1, pre_pipe venv find_alias options pos pipe2) | PipeGroup (loc, info) -> PipeGroup (loc, pre_pipe_group venv find_alias options pos info) | PipeBackground (loc, pipe) -> PipeBackground (loc, pre_pipe venv find_alias options pos pipe) and pre_pipe_group venv find_alias options pos info = let { group_stdin = stdin; group_stdout = stdout; group_pipe = pipe; _ } = info in { info with group_stdin = arg_of_redirect venv pos stdin; group_stdout = arg_of_redirect venv pos stdout; group_pipe = pre_pipe venv find_alias options pos pipe } (* * Do the whole command-line parsing process. *) let pipe_of_value venv find_alias options pos loc v = let pos = string_pos "pipe_of_value" pos in let argv = tokens_of_value venv pos lexer v in let flags, argv = collect_flags argv in let pipe = parse loc argv in let pipe = pre_pipe venv find_alias options pos pipe in flags, pipe (* * Commands with a leading \ are quoted. *) let parse_command_string s = let len = String.length s in if len <> 0 && s.[0] = '\\' then ExeQuote (String.sub s 1 (pred len)) else ExeString s (* * -*- * Local Variables: * Fill-column: 100 * End: * -*- * vim:ts=3:et:tw=100 *) omake-0.10.3/src/shell/omake_shell_job.ml0000644000175000017500000010531513177364665016707 0ustar gerdgerdmodule Pos = Omake_pos.Make (struct let name = "Omake_shell_job" end) module IntCompare = struct type t = int let compare = (-) end module IntSet = Lm_set.LmMake (IntCompare) module IntTable = Lm_map.LmMake (IntCompare) module PidSet = IntSet module PidTable = IntTable (* * Subjob info. *) type job_state = | JobForeground | JobBackground | JobSuspended type job_status = | JobExited of int | JobSignaled of int | JobStopped of int type subjob_cond = { cond_op : Omake_shell_type.pipe_op; cond_pipe : Omake_env.string_pipe; cond_stdin : Unix.file_descr; cond_stdout : Unix.file_descr; cond_stderr : Unix.file_descr } and subjob_exp = | SubjobProcess of Omake_shell_sys_type.pid * Omake_env.t | SubjobPipe of subjob_exp * subjob_exp | SubjobFinished of job_status * Omake_env.t | SubjobCond of subjob_exp * subjob_cond (* * Job info. * The job has an identifier, * a process group, and an expression of what to compute. *) type job = { job_id : int; job_pipe : Omake_env.string_pipe option; mutable job_pgrp : Omake_shell_sys_type.pgrp; mutable job_state : job_state } (* * Info for this shell. * There can be only one shell, and it has a controlling terminal. * Invariant: if the pid is 0, then this job controls the terminal. *) type shell = { mutable shell_jobs : job IntTable.t } (* * Global shell. *) let shell = { shell_jobs = IntTable.empty } (************************************************************************ * Printing. *) (* * Print a job state. *) let pp_print_job_state buf state = let s = match state with | JobForeground -> "Running" | JobBackground -> "Background" | JobSuspended -> "Suspended" in Format.pp_print_string buf s (* * Job may be a pipe. *) let pp_print_pipe_option buf opt = match opt with | Some pipe -> Omake_env.pp_print_string_pipe buf pipe | None -> Format.pp_print_string buf "" (* * Job status. *) let pp_print_status buf code = match code with JobExited code -> Format.fprintf buf "exited with code %d" code | JobSignaled code -> Format.fprintf buf "exited with signal %d" code | JobStopped code -> Format.fprintf buf "stopped with code %d" code (* * Print a job expression. *) (* let rec pp_print_exp buf e = *) (* match e with *) (* SubjobProcess (pid, _) -> *) (* Format.fprintf buf "(%d)" pid *) (* | SubjobPipe (e1, e2) -> *) (* Format.fprintf buf "@[(%a@ | %a)@]" pp_print_exp e1 pp_print_exp e2 *) (* | SubjobCond (e, cond) -> *) (* let { cond_op = op; *) (* cond_pipe = pipe; *) (* _ *) (* } = cond *) (* in *) (* Format.fprintf buf "@[(%a)@ %a@ %a@]" (\**\) *) (* pp_print_exp e *) (* pp_print_pipe_op op *) (* Omake_env.pp_print_string_pipe pipe *) (* | SubjobFinished (code, _) -> *) (* Format.fprintf buf "[Finished: %a]" pp_print_status code *) (* * Print a job. *) let pp_print_job buf job = let { job_id = id; job_pgrp = pgrp; job_state = state; job_pipe = pipe } = job in Format.fprintf buf "@[[%d] (%d) %a@ - %a@]" (**) id pgrp pp_print_job_state state pp_print_pipe_option pipe (* * Status code printing. *) let print_exit_code venv force pid code = match code with JobExited 0 -> if force then Format.eprintf "- %d: done@." pid | JobExited code -> if force || Omake_env.venv_defined venv Omake_var.printexitvalue_var then Format.eprintf "- %d: exited with code %d@." pid code | JobSignaled code -> Format.eprintf "- %d: terminated with signal %d@." pid code | JobStopped code -> Format.eprintf "- %d: stopped with code %d@." pid code (************************************************************************ * Utilities *) (* * Get an array representation of the environment. *) let array_of_env env fields = let env = List.fold_left (fun env (v, x) -> Lm_symbol.SymbolTable.add env v x) env fields in let env = Lm_symbol.SymbolTable.fold (fun env v x -> Printf.sprintf "%s=%s" (Lm_symbol.string_of_symbol v) x :: env) [] env in Array.of_list env (* * Figure out a common code. * For now, signaling takes precedence. *) let unify_codes code1 code2 = match code1, code2 with JobSignaled code1, JobSignaled code2 -> JobSignaled (max code1 code2) | JobSignaled _, _ -> code1 | _, JobSignaled _ -> code2 | JobExited code1, JobExited code2 -> JobExited (max code1 code2) | _, JobExited _ -> code2 | _ -> code1 (* * Get an integer version of the code. *) let int_of_code code = match code with JobSignaled code | JobExited code | JobStopped code -> code (* * Find the job with the process group. *) let find_job_by_pgrp pgrp = match IntTable.fold (fun job1 _ job2 -> if job2.job_pgrp = pgrp then Some job2 else job1) None shell.shell_jobs with Some job -> job | None -> raise Not_found (************************************************************************ * Job management. *) (* * Create a new job. *) let new_job pgrp pipe = let rec new_id i = if IntTable.mem shell.shell_jobs i then new_id (succ i) else i in let id = new_id 1 in let job = { job_id = id; job_pipe = pipe; job_pgrp = pgrp; job_state = JobForeground } in shell.shell_jobs <- IntTable.add shell.shell_jobs id job; job (* * Remove a job from the shell. *) let remove_job job = shell.shell_jobs <- IntTable.remove shell.shell_jobs job.job_id (* * Create a simple thread. * We have a function and channels. *) let create_top_thread _ f stdin stdout stderr = if !Omake_shell_type.debug_shell then Format.eprintf "create_top_thread@."; let apply_fun stdin stdout stderr _ = f stdin stdout stderr in let thread_info : Omake_shell_sys_type.create_thread = {create_thread_stdin = stdin; create_thread_stdout = stdout; create_thread_stderr = stderr; create_thread_pgrp = 0; create_thread_fun = apply_fun; create_thread_background = true } in Omake_shell_sys.create_thread thread_info (* * Create the diversion channels. *) let string_of_redirect (chan : string Omake_shell_type.redirect) = match chan with | RedirectNode node -> Some (Omake_node.Node.fullname node) | RedirectArg s -> Some s | RedirectNone -> None let create_channels stdin stdin_file append stdout stdout_file stderr_divert stderr = let stdin, close_stdin = match string_of_redirect stdin_file with Some file -> Lm_unix_util.openfile file [Unix.O_RDONLY; Unix.O_NOCTTY] 0, true | None -> stdin, false in let stdout, close_stdout = match string_of_redirect stdout_file with Some file -> let flags = [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_NOCTTY] in let flags = if append then Unix.O_APPEND :: flags else Unix.O_TRUNC :: flags in (try Lm_unix_util.openfile file flags 0o666, true with exn -> if close_stdin then Omake_shell_sys.close_fd stdin; raise exn) | None -> stdout, false in let () = if append then ignore (Unix.lseek stdout 0 Unix.SEEK_END) in let stderr = if stderr_divert then stdout else stderr in stdin, close_stdin, stdout, close_stdout, stderr (* * Application at the toplevel. * Don't create a thread. *) (* let restore_vars = [stdin_sym; stdout_sym; stderr_sym] *) let create_apply_top venv stdin stdout stderr apply = match apply with { Omake_shell_type.apply_env = env; apply_fun = f; apply_args = args; apply_stdin = stdin_file; apply_stdout = stdout_file; apply_stderr = stderr_divert; apply_append = append; _ } -> let stdin, close_stdin, stdout, close_stdout, stderr = create_channels stdin stdin_file append stdout stdout_file stderr_divert stderr in let cleanup () = if close_stdin then Omake_shell_sys.close_fd stdin; if close_stdout then Omake_shell_sys.close_fd stdout in (* The function will close its files on its own *) try if !Omake_shell_type.debug_shell then Format.eprintf "create_apply_top pid=%i: duplicating channels@." (Unix.getpid ()); let stdin = Unix.dup stdin in let stdout = Unix.dup stdout in let stderr = Unix.dup stderr in let info = f venv stdin stdout stderr env args in if !Omake_shell_type.debug_shell then Format.eprintf "create_apply_top pid=%i: done@." (Unix.getpid ()); cleanup (); info with Omake_value_type.ExitException (_, code) -> if !Omake_shell_type.debug_shell then Format.eprintf "create_apply_top pid=%i: exit exception: %i@." (Unix.getpid ()) code; cleanup (); code, venv, Omake_value_type.ValOther (ValExitCode code) | Omake_value_type.ExitParentException (pos, code) -> if !Omake_shell_type.debug_shell then Format.eprintf "create_apply_top pid=%i: exit from parent exception: %i@." (Unix.getpid ()) code; cleanup (); raise (Omake_value_type.ExitException (pos, code)) | exn -> if !Omake_shell_type.debug_shell then Format.eprintf "create_apply_top pid=%i: error: %a@." (Unix.getpid ()) Omake_exn_print.pp_print_exn exn; cleanup (); raise exn (* * Start an application in a particular subjob. *) let create_apply venv pgrp bg stdin stdout stderr apply = if !Omake_shell_type.debug_shell then Format.eprintf "create_apply@."; let { Omake_shell_type. apply_env = env; apply_fun = f; apply_args = args; apply_stdin = stdin_file; apply_stdout = stdout_file; apply_stderr = stderr_divert; apply_append = append; _ } = apply in let stdin, close_stdin, stdout, close_stdout, stderr = create_channels stdin stdin_file append stdout stdout_file stderr_divert stderr in (* The actual function call *) let apply_fun stdin stdout stderr _ = let code, _, _ = f venv stdin stdout stderr env args in code in let thread_info : Omake_shell_sys_type.create_thread = { create_thread_stdin = stdin; create_thread_stdout = stdout; create_thread_stderr = stderr; create_thread_pgrp = pgrp; create_thread_fun = apply_fun; create_thread_background = bg } in let cleanup () = if close_stdin then Omake_shell_sys.close_fd stdin; if close_stdout then Omake_shell_sys.close_fd stdout in try let pid = Omake_shell_sys.create_thread thread_info in cleanup (); pid with exn -> cleanup (); raise exn (* * Resolve the absolute name of the executable. *) let find_executable_string venv pos loc exe = let pos = Pos.string_pos "find_executable" pos in let cache = Omake_env.venv_cache venv in if not (Filename.is_relative exe) || Lm_string_util.contains_any exe Lm_filename_util.separators then let rec resolve_exe = function suff :: suffixes -> let node = Omake_env.venv_intern venv PhonyProhibited (exe ^ suff) in if Omake_cache.exists cache node then node else resolve_exe suffixes | [] -> raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, StringStringError ("command not found", exe))) in resolve_exe Omake_cache.exe_suffixes else let path = Omake_env.venv_find_var venv pos loc Omake_var.path_var in let path = Omake_eval.path_of_values venv pos (Omake_value.values_of_value venv pos path) "." in let path = Omake_cache.ls_exe_path cache path in try Omake_cache.exe_find cache path exe with Not_found -> raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, StringStringError ("command not found in PATH", exe))) let find_executable venv pos loc (exe : Omake_shell_type.simple_exe) = let node = match exe with | ExeQuote exe | ExeString exe -> find_executable_string venv pos loc exe | ExeNode node -> if Omake_cache.exe_suffixes = [""] || Omake_cache.exists (Omake_env.venv_cache venv) ~force:true node then node else find_executable_string venv pos loc (Omake_node.Node.absname node) in Omake_node.Node.absname node (* * Start a command. *) let create_command venv pgrp bg stdin stdout stderr (command : (Omake_shell_type.simple_exe, string, string) Omake_shell_type.poly_cmd) = match command with { cmd_loc = loc; cmd_env = env; cmd_exe = exe; cmd_argv = argv; cmd_stdin = stdin_file; cmd_stdout = stdout_file; cmd_append = append; cmd_stderr = stderr_divert } -> let pos = Pos.string_pos "Omake_shell_job.create_command" (Pos.loc_exp_pos loc) in let exe = find_executable venv pos loc exe in let stdin, close_stdin, stdout, close_stdout, stderr = create_channels stdin stdin_file append stdout stdout_file stderr_divert stderr in let dir = Omake_node.Dir.absname (Omake_env.venv_dir venv) in (* Create a process *) let current_env = Omake_env.venv_environment venv in let proc_info : Omake_shell_sys_type.create_process = { create_process_stdin = stdin; create_process_stdout = stdout; create_process_stderr = stderr; create_process_pgrp = pgrp; create_process_env = array_of_env current_env env; create_process_dir = dir; create_process_exe = exe; create_process_argv = Array.of_list (exe :: argv); create_process_background = bg } in let cleanup () = if close_stdin then Omake_shell_sys.close_fd stdin; if close_stdout then Omake_shell_sys.close_fd stdout in if !Omake_shell_type.debug_shell then Format.eprintf "Creating command: %s@." exe; try let pid = Omake_shell_sys.create_process proc_info in cleanup (); if !Omake_shell_type.debug_shell then Format.eprintf "Command created: pid=%i@." pid; pid with exn -> cleanup (); begin match exn with Failure err -> let format_error buf = Format.fprintf buf "@[Spawning %s failed:@ %s@]" exe err in raise (Omake_value_type.OmakeException(pos, LazyError format_error)) | Unix.Unix_error(err, cmd, arg) -> let format_error buf = Format.fprintf buf "@[Spawning %s failed:@ @[%s" exe cmd; if (arg <> "") then Format.fprintf buf "@ %s" arg; Format.fprintf buf ":@ %s@]@]" (Unix.error_message err) in raise (Omake_value_type.OmakeException(pos, LazyError format_error)) | _ -> raise exn end (* * Evaluate a conditional, to see if the conditional operation should be performed. *) let cond_continue (op : Omake_shell_type.pipe_op) (x : job_status ) = match x with | JobExited 0 -> (match op with Omake_shell_type.PipeAnd | PipeSequence -> true | PipeOr -> false) | JobExited _ -> (match op with PipeOr | PipeSequence -> true | PipeAnd -> false) | _ -> false (* * Create a conditional. *) let rec create_cond venv pgrp stdin stdout stderr op pipe1 pipe2 = let cond = { cond_op = op; cond_pipe = pipe2; cond_stdin = stdin; cond_stdout = stdout; cond_stderr = stderr } in let exp = create_pipe_aux venv pgrp false stdin stdout stderr pipe1 in SubjobCond (exp, cond) (* * Create an actual pipe. *) and create_compose venv pgrp stdin stdout stderr divert_stderr pipe1 pipe2 = let stdin', stdout' = Unix.pipe () in let stderr' = if divert_stderr then stdout' else stderr in let () = Omake_shell_sys.set_close_on_exec stdout' in let exp2 = try create_pipe_aux venv pgrp true stdin' stdout stderr pipe2 with exn -> Omake_shell_sys.close_fd stdin'; Omake_shell_sys.close_fd stdout'; raise exn in let () = Omake_shell_sys.close_fd stdin' in let () = Omake_shell_sys.clear_close_on_exec stdout' in let exp1 = try create_pipe_aux venv pgrp true stdin stdout' stderr' pipe1 with Omake_value_type.OmakeException _ | Unix.Unix_error _ | Failure _ as exn -> Format.eprintf "%a@." Omake_exn_print.pp_print_exn exn; SubjobFinished (JobExited Omake_state.exn_error_code, venv) | exn -> Omake_shell_sys.close_fd stdout'; ignore(wait_exp pgrp exp2); raise exn in Omake_shell_sys.close_fd stdout'; SubjobPipe (exp1, exp2) (* * Create a subshell. *) and create_shell venv pgrp bg stdin stdout stderr pipe = if !Omake_shell_type.debug_shell then Format.eprintf "create_shell@."; let create_fun stdin stdout stderr pgrp = let exp = try create_pipe_aux venv pgrp false stdin stdout stderr pipe with Omake_value_type.ExitException (_, code) -> SubjobFinished (JobExited code, venv) | exn -> Format.eprintf "@[%a@ Process group exception.@]@." Omake_exn_print.pp_print_exn exn; raise exn in let code = wait_exp pgrp exp in Omake_shell_sys.close_fd stdin; Omake_shell_sys.close_fd stdout; Omake_shell_sys.close_fd stderr; code in let thread_info : Omake_shell_sys_type.create_thread = { create_thread_stdin = stdin; create_thread_stdout = stdout; create_thread_stderr = stderr; create_thread_pgrp = pgrp; create_thread_fun = create_fun; create_thread_background = bg } in Omake_shell_sys.create_thread thread_info (* * Create a grouped operation. *) and create_group venv pgrp stdin stdout stderr group = if !Omake_shell_type.debug_shell then Format.eprintf "create_group@."; let { Omake_shell_type.group_stdin = stdin_file; group_stdout = stdout_file; group_stderr = stderr_divert; group_append = append; group_pipe = pipe } = group in let stdin, close_stdin, stdout, close_stdout, stderr = create_channels stdin stdin_file append stdout stdout_file stderr_divert stderr in let create_fun stdin stdout stderr pgrp = let exp = try create_pipe_aux venv pgrp false stdin stdout stderr pipe with Omake_value_type.ExitException (_, code) -> SubjobFinished (JobExited code, venv) | exn -> Format.eprintf "@[%a@ Process group exception.@]@." Omake_exn_print.pp_print_exn exn; raise exn in let code = wait_exp pgrp exp in Omake_shell_sys.close_fd stdin; Omake_shell_sys.close_fd stdout; Omake_shell_sys.close_fd stderr; code in let thread_info : Omake_shell_sys_type.create_thread = { create_thread_stdin = stdin; create_thread_stdout = stdout; create_thread_stderr = stderr; create_thread_pgrp = pgrp; create_thread_fun = create_fun; create_thread_background = true } in let pid = Omake_shell_sys.create_thread thread_info in if close_stdin then Omake_shell_sys.close_fd stdin; if close_stdout then Omake_shell_sys.close_fd stdout; (* Groups are suposed to be in a separate scope, use the original venv *) SubjobProcess (pid, venv) (* * Create the pipe. *) and create_pipe_aux venv pgrp fork stdin stdout stderr pipe = if !Omake_shell_type.debug_shell then Format.eprintf "create_pipe_aux (fork: %b): %a@." fork Omake_env.pp_print_string_pipe pipe; match pipe with PipeApply (_, apply) -> if fork then SubjobProcess (create_apply venv pgrp true stdin stdout stderr apply, venv) else let code, venv, _ = create_apply_top venv stdin stdout stderr apply in SubjobFinished (JobExited code, venv) | PipeCommand (_, command) -> SubjobProcess (create_command venv pgrp true stdin stdout stderr command, venv) | PipeCond (_, op, pipe1, pipe2) -> if fork then SubjobProcess (create_shell venv pgrp true stdin stdout stderr pipe, venv) else create_cond venv pgrp stdin stdout stderr op pipe1 pipe2 | PipeCompose (_, divert_stderr, pipe1, pipe2) -> create_compose venv pgrp stdin stdout stderr divert_stderr pipe1 pipe2 | PipeGroup (_, group) -> create_group venv pgrp stdin stdout stderr group | PipeBackground (_, pipe) -> create_pipe_aux venv pgrp true stdin stdout stderr pipe (* * Create a thread. This may actually be a separate * process. *) and create_thread venv f stdin stdout stderr = if !Omake_shell_type.debug_shell then Format.eprintf "Creating thread@."; (* Evaluate application eagerly *) let pgrp = create_top_thread venv f stdin stdout stderr in let job = new_job pgrp None in if !Omake_shell_type.debug_shell then Format.eprintf "Started thread with pgrp %i, internal id %i@." job.job_pgrp job.job_id; job.job_state <- JobBackground; Omake_env.InternalPid job.job_id (* * Wait for a subjob to finish. * This is only executed in a subprocess, * so the appropriate thing to do when finished * is exit. *) and wait_exp pgrp exp = match eval_exp_top pgrp exp with SubjobFinished (JobExited code, _) | SubjobFinished (JobSignaled code, _) -> if !Omake_shell_type.debug_shell then Format.eprintf "wait_exp: %i exiting %d@." (Unix.getpid()) code; code | exp -> wait_exp2 pgrp exp and wait_exp2 pgrp exp = (* Wait for a job to complete; ignore stopped processes *) if !Omake_shell_type.debug_shell then Format.eprintf "wait_exp2: %i waiting for pgrp %i@." (Unix.getpid()) pgrp; let code = try Some (Omake_shell_sys.wait pgrp false false) with Unix.Unix_error (Unix.EINTR, _, _) -> None in if !Omake_shell_type.debug_shell then Format.eprintf "wait_exp: some event happened@."; match code with None | Some (_, Unix.WSTOPPED _) -> wait_exp2 pgrp exp | Some (pid, (Unix.WEXITED _| Unix.WSIGNALED _ as code)) -> let code = match code with Unix.WEXITED code -> JobExited code | Unix.WSIGNALED code -> JobSignaled code | Unix.WSTOPPED _ -> raise (Invalid_argument "Omake_shell_job.wait_exp2: internal error") in (* Evaluate the expression *) if !Omake_shell_type.debug_shell then Format.eprintf "wait_exp2: %i handling event: pid=%d@." (Unix.getpid()) pid; let exp = eval_exp pgrp exp pid code in wait_exp pgrp exp (* * Evaluate the expression. *) and eval_exp_top pgrp e = eval_exp pgrp e 0 (JobExited 0) and eval_exp pgrp e pid code = if !Omake_shell_type.debug_shell then Format.eprintf "eval_exp in %i: pgrp=%i, pid=%i@." (Unix.getpid()) pgrp pid; let rec eval e = match e with SubjobProcess (pid', venv) -> if pid' = pid then SubjobFinished (code, venv) else e | SubjobPipe (e1, e2) -> (match eval e1, eval e2 with SubjobFinished (code1, _), SubjobFinished (code2, venv) -> SubjobFinished (unify_codes code1 code2, venv) | e1, e2 -> SubjobPipe (e1, e2)) | SubjobCond (e, cond) -> if !Omake_shell_type.debug_shell then Format.eprintf "eval_exp in %i: evaluating SubjobCond@." (Unix.getpid()); (match eval e with SubjobFinished (code, venv) -> let { cond_op = op; cond_pipe = pipe; cond_stdin = stdin; cond_stdout = stdout; cond_stderr = stderr } = cond in if cond_continue op code then eval_exp_top pgrp (create_pipe_aux venv pgrp false stdin stdout stderr pipe) else SubjobFinished (code, venv) | e -> SubjobCond (e, cond)) | SubjobFinished _ -> e in eval e (* * Utility function for wait_top_aux and cleanup_top_aux *) let finalize_job job = function Unix.WEXITED code -> remove_job job; JobExited code | Unix.WSIGNALED code -> remove_job job; JobSignaled code | Unix.WSTOPPED code -> job.job_state <- JobSuspended; JobStopped code (* * Wait for a job to finish. * This is executed in the main process. * Do not give away the terminal. *) let rec wait_top_aux job = let pgrp = job.job_pgrp in if !Omake_shell_type.debug_shell then Format.eprintf "wait_top_aux: will wait for pgrp %i@." pgrp; let pid, status = Omake_shell_sys.wait pgrp true false in if !Omake_shell_type.debug_shell then Format.eprintf "wait_top_aux: got pid %d@." pid; if pid <> pgrp then wait_top_aux job else let code = finalize_job job status in if !Omake_shell_type.debug_shell then Format.eprintf "wait_top_aux: %a@." pp_print_status code; code, status let wait_top venv job = let code, _ = wait_top_aux job in Omake_shell_sys.set_tty_pgrp 0; print_exit_code venv false job.job_id code; code let wait_pid _ job = let _, status = wait_top_aux job in Omake_shell_sys.set_tty_pgrp 0; status (* * Create a pipe. * If this is a simple job, do not monitor the pipe. *) let rec create_pipe_exn venv bg stdin stdout stderr = function | Omake_shell_type.PipeApply (_, apply) -> create_apply venv 0 bg stdin stdout stderr apply | PipeCommand (_, command) -> create_command venv 0 bg stdin stdout stderr command | PipeCond _ | PipeCompose _ | PipeGroup _ as pipe -> create_shell venv 0 bg stdin stdout stderr pipe | PipeBackground (_, pipe) -> create_pipe_exn venv true stdin stdout stderr pipe (* * When the pipe is created: * If the pipe is in the background, the terminal remains attached. * If the pipe is not in the background, we retain control of the terminal. * * WARNING: this function should not be called if * 1. the pipeline is an alias, and * 2. the output is a pipe connected internally. * The reason is that the alias is not processed in a thread. * If it generates a lot of output, it will block, causing * deadlock because the output processor is not being run. * * Remember that rules pass their output to the output * processor through a pipe like this. However, commands * in rules are processed by create_process, not create_job. *) let rec create_job_aux venv pipe stdin stdout stderr = if !Omake_shell_type.debug_shell then Format.eprintf "Creating pipe: %a@." Omake_env.pp_print_string_pipe pipe; match pipe with PipeApply (_, apply) -> (* Evaluate applications eagerly *) create_apply_top venv stdin stdout stderr apply | PipeBackground (_, pipe) -> (* Create a background job *) let pgrp = create_pipe_exn venv true stdin stdout stderr pipe in let job = new_job pgrp (Some pipe) in job.job_state <- JobBackground; 0, venv, ValNone | PipeCompose _ (* * XXX: TODO (Aleksey 2007/06/26) * PipeCompose should be handled similar to PipeCond, where only the left hand * side should be forked, while the right hand side should be evaluated in the current process. *) | PipeGroup _ | PipeCommand _ -> (* Otherwise, fork a foreground job *) let pgrp = create_pipe_exn venv false stdin stdout stderr pipe in let job = new_job pgrp (Some pipe) in if !Omake_shell_type.debug_shell then Format.eprintf "Running pgrp %d (my pid = %d)@." pgrp (Unix.getpid ()); (* * On Mac OSX this call fails with EPERM. * I believe this is because the sub-process * sets the controlling terminal itself (see * Omake_shell_sys_unix.create_process). * * This means that the sub-process takes over the terminal, * and we can't set it anymore. * * This seems like a bogus explanation, because we have * to get the terminal back on suspend... Omake_shell_sys.set_tty_pgrp pgrp; *) let code = int_of_code (wait_top venv job) in code, venv, ValOther (ValExitCode code) | PipeCond (_, op, pipe1, pipe2) -> let (code, venv, _) as info = create_job_aux venv pipe1 stdin stdout stderr in if cond_continue op (JobExited code) then create_job_aux venv pipe2 stdin stdout stderr else info let create_job venv pipe stdin stdout stderr = let _, venv, value = create_job_aux venv pipe stdin stdout stderr in venv, value let is_pipe fd = (* we assume that fd is a pipe when fd is not seekable. This is for an optimization only; returning true is always possible, but we must only return false when no separate thread is needed *) try ignore(Unix.lseek fd 0 Unix.SEEK_CUR); false with | Unix.Unix_error(Unix.ESPIPE,_,_) -> true (* * This is a variation: create the process and return the pid. * These jobs are always background. *) let create_process venv pipe stdin stdout stderr = if !Omake_shell_type.debug_shell then Format.eprintf "Creating process: %a@." Omake_env.pp_print_string_pipe pipe; match pipe with (* * The restriction to stdout and stderr is necessary to * prevent possible blocking on I/O. *) PipeApply (_, apply) when (stdout = Unix.stdout || not(is_pipe stdout)) && (stderr = Unix.stderr || not (is_pipe stderr)) -> let code, venv, value = create_apply_top venv stdin stdout stderr apply in Omake_env.ResultPid (code, venv, value) | _ -> let pgrp = create_pipe_exn venv true stdin stdout stderr pipe in let job = new_job pgrp (Some pipe) in if !Omake_shell_type.debug_shell then Format.eprintf "Started process with pgrg %i, internal id %i@." job.job_pgrp job.job_id; job.job_state <- JobBackground; InternalPid job.job_id (* * This is an explicit wait function. * It is exactly like the wait_top function, * except we print results. *) let wait job = let id = job.job_id in try match fst (wait_top_aux job) with JobExited 0 -> Format.eprintf "*** osh: [%d] Done@." id | JobExited code -> Format.eprintf "*** osh: [%d] Exited with code %d@." id code | JobSignaled code -> Format.eprintf "*** osh: [%d] Signaled with code %d@." id code | JobStopped _ -> Format.eprintf "*** osh: [%d] Stopped@." id with Unix.Unix_error (Unix.EINTR, _, _) | Sys.Break -> Format.eprintf "*** osh: [%d] Wait interrupted@." id (* * Clear out any processes that have completed. *) let cleanup_top_aux () = if !Omake_shell_type.debug_shell then Format.eprintf "cleanup_top_aux@."; let pid, status = Omake_shell_sys.wait 0 true true in let job = find_job_by_pgrp pid in let pid = job.job_id in let code = finalize_job job status in if !Omake_shell_type.debug_shell then Format.eprintf "cleanup_top_aux: %a@." pp_print_status code; pid, code let rec cleanup venv = let code = try Some (cleanup_top_aux ()) with Not_found | Unix.Unix_error _ -> None in match code with Some (pid, code) -> print_exit_code venv true pid code; cleanup venv | None -> () (* * Place it in the background. * It should be currently suspended. *) let bg_job job = Omake_shell_sys.kill job.job_pgrp SigCont; job.job_state <- JobBackground (* * Bring a job to the foreground. * Give it the terminal. *) let fg_job venv job = Omake_shell_sys.set_tty_pgrp job.job_pgrp; Omake_shell_sys.kill job.job_pgrp SigCont; job.job_state <- JobForeground; wait_top venv job (* * Stop a job. *) let stop_job venv job = Omake_shell_sys.kill job.job_pgrp SigStop; wait_top venv job (* * Kill a job. *) let kill_job job signal = Omake_shell_sys.kill job.job_pgrp signal (************************************************************************ * Toplevel shell utilities. *) (* * List the jobs. *) let jobs _ = IntTable.iter (fun _ job -> Format.printf "%a@." pp_print_job job) shell.shell_jobs (* * Get the identified job. *) let job_of_pid pos pid = try IntTable.find shell.shell_jobs pid with Not_found -> raise (Omake_value_type.OmakeException (pos, StringIntError ("Omake_shell_job.job_of_pid: no such job", pid))) (* * Process management. *) let bg _ pos pid = let pos = Pos.string_pos "bg" pos in bg_job (job_of_pid pos pid) let fg venv pos pid = let pos = Pos.string_pos "fg" pos in ignore (fg_job venv (job_of_pid pos pid)) let stop venv pos pid = let pos = Pos.string_pos "stop" pos in ignore (stop_job venv (job_of_pid pos pid)) let kill _ pos pid signal = let pos = Pos.string_pos "kill" pos in kill_job (job_of_pid pos pid) signal let wait _ pos pid = let pos = Pos.string_pos "wait" pos in wait (job_of_pid pos pid) let waitpid venv pos (pid : Omake_env.pid) : int * Unix.process_status * Omake_value_type.t= let pos = Pos.string_pos "waitpid" pos in match pid with | ExternalPid pid -> if !Omake_shell_type.debug_shell then Format.eprintf "Omake_shell_job.waitpid: external id %i@." pid; let _, status = Unix.waitpid [] pid in pid, status, Omake_value_type.ValNone | InternalPid pid -> if !Omake_shell_type.debug_shell then Format.eprintf "Omake_shell_job.waitpid: internal id %i@." pid; let status = wait_pid venv (job_of_pid pos pid) in pid, status, ValNone | ResultPid (code, _, value) -> 0, Unix.WEXITED code, value omake-0.10.3/src/shell/omake_shell_sys_win32.ml0000644000175000017500000000762313177364665020000 0ustar gerdgerd(* * System calls. *) open Lm_printf open Omake_shell_type open Omake_shell_sys_type (* * These functions are directly exported. *) external set_tty_pgrp : pgrp -> unit = "omake_shell_sys_set_tty_pgrp" external create_process : create_process -> pid = "omake_shell_sys_create_process" (* * Internal. *) external create_thread_pid : pgrp -> pid = "omake_shell_sys_create_thread_pid" external release_thread_pid : pid -> int -> unit = "omake_shell_sys_release_thread_pid" external init_thread_pid : pid -> unit = "omake_shell_sys_init_thread_pid" external check_thread : unit -> bool = "omake_shell_sys_check_thread" external suspend : pgrp -> unit = "omake_shell_sys_suspend" external resume : pgrp -> unit = "omake_shell_sys_resume" external kill : pgrp -> unit = "omake_shell_sys_kill" external ext_wait : pgrp -> bool -> bool -> bool * pid * int = "omake_shell_sys_wait" external init_shell : unit -> unit = "omake_shell_sys_init" external close : unit -> unit = "omake_shell_sys_close" let () = init_shell (); let pid = Unix.getpid () in let do_close () = if pid == Unix.getpid () then close () in Pervasives.at_exit do_close let set_interactive _ = () let set_close_on_exec = Unix.set_close_on_exec let clear_close_on_exec = Unix.clear_close_on_exec let close_fd = Unix.close (* * Termination signal. *) (* exception Terminated *) (* * The operation depends on the signal number. *) let kill pgrp signo = match signo with SigStop | SigTstp -> suspend pgrp | SigCont -> resume pgrp | _ -> kill pgrp (* * Wait is blocking. *) let unix_wait pgrp leader nohang = let exited, pid, code = ext_wait pgrp leader nohang in let status = if exited then Unix.WEXITED code else Unix.WSTOPPED code in pid, status let wait pgrp leader nohang = Lm_thread_pool.blocking_section (unix_wait pgrp leader) nohang (* * Try to close a descriptor. * This is kind of bad, because some other thread * may have allocated that descriptor by the time we get * to it, but this should never happen because the thread * should be catching all its exceptions. *) let try_close fd = try close_fd fd with Unix.Unix_error _ -> () (* * Create a thread. This is a real thread, but it * should look as much like a process as possible. * For this reason, we dup the stdio handles. *) let create_thread info = let { create_thread_stdin = stdin; create_thread_stdout = stdout; create_thread_stderr = stderr; create_thread_pgrp = pgrp; create_thread_fun = f; _ } = info in Pervasives.flush_all(); let pid = create_thread_pid pgrp in let stdin = Unix.dup stdin in let stdout = Unix.dup stdout in let stderr = Unix.dup stderr in let cleanup () = try_close stdin; try_close stdout; try_close stderr in let _ = Lm_thread_pool.create false (fun () -> init_thread_pid pid; let code = try f stdin stdout stderr pid with Omake_value_type.ExitException (_, code) -> cleanup (); code | Sys.Break as exn -> cleanup(); raise exn | exn -> eprintf "@[%a@ Thread failed with an exception, cleaning up@]@." Omake_exn_print.pp_print_exn exn; cleanup (); Omake_state.exn_error_code in release_thread_pid pid code) in pid (* * Create a new process group. *) let create_process_group = create_thread omake-0.10.3/src/shell/omake_shell_completion.ml0000644000175000017500000001444713177364665020313 0ustar gerdgerd(* * Completion functions for the interactive shell. * *) open Lm_string_set open Omake_env open Omake_var open Omake_node open Omake_value open Omake_value_type module Pos = Omake_pos.Make (struct let name = "Omake_shell_job" end) open Pos;; (* * Filename operations not already implemented in Lm_filename_util. *) let is_compound_path name = Lm_string_util.contains_any name Lm_filename_util.separators let split_last name = let i = Lm_string_util.rindex_set name Lm_filename_util.separators in let prefix = String.sub name 0 (i + 1) in let head = String.sub name 0 i in let tail = String.sub name (i + 1) (String.length name - i - 1) in prefix, head, tail let split_relative name = if is_compound_path name then split_last name else "", "", name let split_triple name = let i = Lm_string_util.index_set name Lm_filename_util.separators in let j = Lm_string_util.rindex_set name Lm_filename_util.separators in let prefix = String.sub name 0 (j + 1) in let first = String.sub name 0 i in let dir = if i = j then "" else String.sub name (i + 1) (j - i - 1) in let name = String.sub name (j + 1) (String.length name - j - 1) in prefix, first, dir, name (* * We are given a partial username ~xy * Find all the usernames with prefix xy. *) let username_completion_exn s = let name = String.sub s 1 (String.length s - 1) in let users = Lm_glob.getusers () in List.fold_left (fun users user -> if Lm_string_util.is_string_prefix name user then StringSet.add users ("~" ^ user) else users) StringSet.empty users (* * List the filenames in the directory that match the * given name. *) let list_completion_exn prefix dir name = let names = Array.to_list (Sys.readdir dir) in List.fold_left (fun names n -> if Lm_string_util.is_string_prefix name n then StringSet.add names (prefix ^ n) else names) StringSet.empty names (* * We are given an absolute name /ab/cd/ef. * A path /abc is a special case. *) let absolute_completion_exn s = let prefix, dir, name = split_last s in let dir = if dir = "" then "/" else dir in list_completion_exn prefix dir name (* * We are given a relative name ab/cd/ef. * Compute it relative to the current directory. *) let relative_completion_exn venv _ _ s = let cwd = Dir.fullname (venv_dir venv) in let prefix, dir, name = split_relative s in let dir = Filename.concat cwd dir in list_completion_exn prefix dir name (* * We are given a home directory name ~abc/def/geh *) let homedir_completion_exn s = let prefix, user, dir, name = split_triple s in let home = if user = "~" then Lm_glob.home_dir else Lm_glob.gethomedir (String.sub user 1 (String.length user - 1)) in let dir = Filename.concat home dir in list_completion_exn prefix dir name (* * Filename completion has several cases: * ~xy : partial username should be completed * ~xy/foo : partial filename should be completed * /foo/bar : partial absolute filename should be completed * foo/bar : partial relative filename should be completed *) let filename_completion_exn venv pos loc s = let pos = string_pos "filename_completion" pos in let len = String.length s in let () = if len = 0 then raise Not_found in if s.[0] = '~' then if is_compound_path s then homedir_completion_exn s else username_completion_exn s else if Lm_filename_util.is_absolute s then absolute_completion_exn s else relative_completion_exn venv pos loc s (* * Command completion uses the Omake_cache. *) let command_completion_exn venv pos _loc s = let pos = string_pos "command_completion" pos in (* Aliases *) let shell_obj = venv_find_var_exn venv shell_object_var in let items1 = match eval_single_value venv pos shell_obj with ValObject obj -> venv_object_fold_internal (fun items v _ -> let s2 = Lm_symbol.to_string v in if Lm_string_util.is_string_prefix s s2 then StringSet.add items s2 else items) StringSet.empty obj | _ -> StringSet.empty in (* Commands *) let cache = venv_cache venv in let path = venv_find_var_exn venv path_var in let path = Omake_eval.path_of_values venv pos (values_of_value venv pos path) "." in let path = Omake_cache.ls_exe_path cache path in let items2 = Omake_cache.exe_complete cache path s in StringSet.union items2 items1 (* * For readline, the result requires that the first entry * be the maximal prefix of all the entries. *) let rec char_matches c i names = match names with name :: names -> name.[i] = c && char_matches c i names | [] -> true let rec min_string_length i names = match names with name :: names -> min_string_length (min i (String.length name)) names | [] -> i let rec search_matches i len name names = if i = len then i else if char_matches name.[i] i names then search_matches (i + 1) len name names else i let complete_names s names = let names = StringSet.to_list names in let off = String.length s in match names with [name] -> (* Optimization *) [| name; name |] | name :: rest -> let len = min_string_length (String.length name) rest in let len = search_matches off len name rest in let prefix = String.sub name 0 len in Array.of_list (prefix :: names) | [] -> [||] (* * Catch all exceptions we might expect. *) let catch f venv pos loc s = try complete_names s (f venv pos loc s) with | Not_found | Sys_error _ (* TODO might refined later *) | OmakeException _ -> [||] let set_completion_functions venv pos loc = let filename_completion s = catch filename_completion_exn venv pos loc s in let command_completion s = catch command_completion_exn venv pos loc s in Callback.register "omake_filename_completion" filename_completion; Callback.register "omake_command_completion" command_completion omake-0.10.3/src/shell/omake_shell_sys_type.ml0000644000175000017500000000414113177364666020010 0ustar gerdgerd(* * Architecture-independent process control. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004 Mojave Group, Caltech * * 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; version 2 * of the License. * * 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, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * * Additional permission is given to link this library with the * with the Objective Caml runtime, and to redistribute the * linked executables. See the file LICENSE.OMake for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) (* * Process and group identifiers. *) type pgrp = int type pid = int (* * Argument records for thread and process creation. *) type create_thread = { create_thread_stdin : Unix.file_descr; create_thread_stdout : Unix.file_descr; create_thread_stderr : Unix.file_descr; create_thread_pgrp : pgrp; create_thread_fun : (Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> pgrp -> int); create_thread_background : bool } type create_process = { create_process_stdin : Unix.file_descr; create_process_stdout : Unix.file_descr; create_process_stderr : Unix.file_descr; create_process_pgrp : pgrp; create_process_dir : string; create_process_env : string array; create_process_exe : string; create_process_argv : string array; create_process_background : bool } (*! * @docoff * * -*- * Local Variables: * Caml-master: "compile" * End: * -*- *) omake-0.10.3/src/shell/omake_shell_sys_unix.ml0000644000175000017500000001505413177364666020017 0ustar gerdgerd(* * System calls. *) (* * These functions are directly exported. *) external ext_set_tty_pgrp : Omake_shell_sys_type.pgrp -> unit = "omake_shell_sys_set_tty_pgrp" external ext_setpgid : Omake_shell_sys_type.pid -> Omake_shell_sys_type.pid -> unit = "omake_shell_sys_setpgid" let interact = ref (Lm_readline.isatty ()) let set_interactive flag = interact := flag let set_tty_pgrp pgrp = if !interact then ext_set_tty_pgrp pgrp let setpgid pid1 pid2 = if !interact then ext_setpgid pid1 pid2 (* * Close-on-exec flags. * We actually want a close-on-fork, so we keep track of * these descriptors. *) module FdCompare = struct type t = Unix.file_descr let compare = Pervasives.compare end module FdSet = Lm_set.LmMake (FdCompare);; let close_on_fork = ref FdSet.empty let close_fd fd = Unix.close fd; close_on_fork := FdSet.remove !close_on_fork fd let set_close_on_exec fd = Unix.set_close_on_exec fd; close_on_fork := FdSet.add !close_on_fork fd let clear_close_on_exec fd = Unix.clear_close_on_exec fd; close_on_fork := FdSet.remove !close_on_fork fd let do_close_on_fork () = FdSet.iter Unix.close !close_on_fork; close_on_fork := FdSet.empty (** Send a signal to a process. *) let signo_of_signal = function | Omake_shell_type.SigAbrt -> Sys.sigabrt | SigAlrm -> Sys.sigalrm | SigFPE -> Sys.sigfpe | SigHup -> Sys.sighup | SigIll -> Sys.sigill | SigInt -> Sys.sigint | SigKill -> Sys.sigkill | SigPipe -> Sys.sigpipe | SigQuit -> Sys.sigquit | SigSegv -> Sys.sigsegv | SigTerm -> Sys.sigterm | SigUsr1 -> Sys.sigusr1 | SigUsr2 -> Sys.sigusr2 | SigChld -> Sys.sigchld | SigCont -> Sys.sigcont | SigStop -> Sys.sigstop | SigTstp -> Sys.sigtstp | SigTtin -> Sys.sigttin | SigTtou -> Sys.sigttou | SigVTAlrm -> Sys.sigvtalrm | SigProf -> Sys.sigprof | SigNum i -> i let kill pgrp signal = Unix.kill pgrp (signo_of_signal signal) (* * Wait for a process to exit. * The leader flag indicates whether to wait for the leader. *) let wait pgrp leader nohang = let flags = if !interact then [Unix.WUNTRACED] else [] in let flags = if nohang then Unix.WNOHANG :: flags else flags in let pid = if pgrp = 0 then -1 else if leader then pgrp else if !interact then -pgrp else -1 in Unix.waitpid flags pid (* * Duplicate file descriptors onto * their standard places. *) let dup stdin stdout stderr = let stdin' = Unix.dup stdin in let stdout' = Unix.dup stdout in let stderr' = Unix.dup stderr in Unix.close stdin; if (stdin <> stdout) then Unix.close stdout; if (stdin <> stderr && stdout <> stderr) then Unix.close stderr; Unix.dup2 stdin' Unix.stdin; Unix.dup2 stdout' Unix.stdout; Unix.dup2 stderr' Unix.stderr; Unix.close stdin'; Unix.close stdout'; Unix.close stderr' let dup_actions workfd stdin stdout stderr = (* Careful: dup2(fd1,fd2) also clears the close-on-exec flag for the duplicate. However, dup2(fd,fd) is, according to POSIX, a no-op. We work around by doing dup2(fd,workfd); dup2(workfd,fd) in sequence (where workfd is an arbitrary other file descriptor) *) let open Omake_shell_spawn in [ Fda_dup2(stdin, workfd); Fda_dup2(workfd, Unix.stdin); Fda_dup2(stdout, workfd); Fda_dup2(workfd, Unix.stdout); Fda_dup2(stderr, workfd); Fda_dup2(workfd, Unix.stderr); Fda_close(workfd); ] @ ( if stdin <> Unix.stdin then [ Fda_close stdin ] else [] ) @ ( if stdout <> Unix.stdout then [ Fda_close stdout ] else [] ) @ ( if stderr <> Unix.stderr && stderr <> stdout then [ Fda_close stderr ] else [] ) (* * Create a thread. * This actually creates a process on Unix. *) let create_thread info = let { Omake_shell_sys_type.create_thread_stdin = stdin; create_thread_stdout = stdout; create_thread_stderr = stderr; create_thread_pgrp = pgrp; create_thread_fun = f; create_thread_background = bg } = info in Pervasives.flush_all(); Lm_unix_util.moncontrol false; let pid = Unix.fork () in if pid = 0 then let code = try let pgrp = if pgrp = 0 then let pid = Unix.getpid () in setpgid pid pid; if not bg then set_tty_pgrp pgrp; pid else pgrp in dup stdin stdout stderr; do_close_on_fork (); ignore (Sys.signal Sys.sigint Sys.Signal_default); ignore (Sys.signal Sys.sigquit Sys.Signal_default); ignore (Sys.signal Sys.sigtstp Sys.Signal_default); f Unix.stdin Unix.stdout Unix.stderr pgrp with Omake_value_type.ExitException (_, code) -> code | exn -> let () = try Format.eprintf "%a@." Omake_exn_print.pp_print_exn exn with _ -> () in Omake_state.exn_error_code in exit code else pid (* * Create a process. *) let create_process info = match info with {Omake_shell_sys_type.create_process_stdin = stdin; create_process_stdout = stdout; create_process_stderr = stderr; create_process_pgrp = pgrp; create_process_dir = dir; create_process_env = env; create_process_exe = exe; create_process_argv = argv; create_process_background = bg } -> (* Format.eprintf "@["; Array.iter (fun s -> Format.eprintf "@ %s" s) argv; Format.eprintf "@]@."; *) Unix.handle_unix_error (fun () -> Lm_unix_util.moncontrol false; let workfd = Unix.openfile "." [Unix.O_RDONLY] 0 in let pid = Omake_shell_spawn.spawn ~chdir:(Omake_shell_spawn.Wd_chdir dir) ~env ~pg:( if !interact && pgrp = 0 then ( if bg then Omake_shell_spawn.Pg_new_bg_group else Omake_shell_spawn.Pg_new_fg_group ) else Omake_shell_spawn.Pg_keep ) ~fd_actions:(dup_actions workfd stdin stdout stderr) exe argv in Unix.close workfd; Lm_unix_util.moncontrol true; pid ) () omake-0.10.3/src/shell/omake_shell_parse.mly0000644000175000017500000002240413177364666017436 0ustar gerdgerd/* * Parser for the command line. * * ---------------------------------------------------------------- * * Copyright (C) 2004-2006 Mojave Group, Caltech * * 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; version 2 * of the License. * * 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, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * * Additional permission is given to link this library with the * with the Objective Caml runtime, and to redistribute the * linked executables. See the file LICENSE.OMake for more details. * * Author: Jason Hickey * Modified By: Aleksey Nogin */ %{ open Lm_location open Omake_shell_type open Omake_value_type module Pos = Omake_pos.Make (struct let name = "Omake_shell_parse" end) (* * If the command is a node, detect it here. *) let collect_redirect chan = match chan with [ValNode node] -> RedirectNode node | _ -> RedirectArg chan (* * Build a command from a sequence of words. *) let null_command loc = { cmd_loc = loc; cmd_env = []; cmd_exe = (); cmd_argv = []; cmd_stdin = RedirectNone; cmd_stdout = RedirectNone; cmd_stderr = false; cmd_append = false } let command_of_values argv loc = { cmd_loc = loc; cmd_env = []; cmd_exe = (); cmd_argv = argv; cmd_stdin = RedirectNone; cmd_stdout = RedirectNone; cmd_stderr = false; cmd_append = false } (* * Diversions. *) let rec set_stdin_inner pipe file = match pipe with PipeApply (loc, apply) -> let apply = { apply with apply_stdin = file } in PipeApply (loc, apply) | PipeCommand (loc, command) -> let command = { command with cmd_stdin = file } in PipeCommand (loc, command) | PipeCond (_, _, _, _) | PipeCompose (_, _, _, _) -> raise (Invalid_argument "Omake_shell_parse.set_stdin: internal error") | PipeGroup (loc, group) -> let group = { group with group_stdin = file } in PipeGroup (loc, group) | PipeBackground (loc, pipe) -> PipeBackground (loc, set_stdin_inner pipe file) let rec set_stdout_inner pipe file stderr append = match pipe with PipeApply (loc, apply) -> let apply = { apply with apply_stdout = file; apply_stderr = stderr; apply_append = append } in PipeApply (loc, apply) | PipeCommand (loc, command) -> let command = { command with cmd_stdout = file; cmd_stderr = stderr; cmd_append = append } in PipeCommand (loc, command) | PipeCond (_, _, _, _) | PipeCompose (_, _, _, _) -> raise (Invalid_argument "Omake_shell_parse.set_stdout: internal error") | PipeGroup (loc, group) -> let group = { group with group_stdout = file; group_stderr = stderr; group_append = append } in PipeGroup (loc, group) | PipeBackground (loc, pipe) -> PipeBackground (loc, set_stdout_inner pipe file stderr append) let set_stdin pipe file = set_stdin_inner pipe (collect_redirect file) let set_stdout pipe file stderr append = set_stdout_inner pipe (collect_redirect file) stderr append %} /* * Terminators */ %token TokEof /* * Indentation tokens are converted in the lexer * to TokBegin/TokEnd. */ %token TokValues %token TokDefine %token TokLeftParen %token TokRightParen %token TokLessThan %token TokGreaterThan %token TokGreaterGreaterThan %token TokAmp %token TokPipe %token TokSemiColon %token TokAnd %token TokOr /* * Pipes are right-associative: * "foo1 | foo2 |& foo3" should _not_ pass foo1's stderr to foo3. * * The pipe has higher precedence that ";" : * "foo1; foo2 | foo3" should redirect only foo2's output, not foo1's. * * The "&&" has higher precedence than "||" (same as in tcsh, different from bash) * * Separately, each of the "&&", "||", and ";" is right-associative (the semantics * is associative, so this does not really matter, but right-associativity is more * efficient at run-time). */ %nonassoc TokAmp %right TokSemiColon %right TokPipe %right TokOr %right TokAnd %nonassoc TokGreaterThan TokGreaterGreaterThan TokLessThan /* * A complete program. */ %start prog %type prog %% /* * Remove the location. */ prog: pipe TokEof { let pipe, _ = $1 in pipe } | TokEof { let loc = $1 in PipeCommand (loc, null_command loc) } ; /* * A pipe is a composition of commands. */ pipe: command { let command, loc = $1 in PipeCommand (loc, command), loc } | pipe TokSemiColon pipe { let pipe1, loc1 = $1 in let pipe2, loc2 = $3 in let loc = union_loc loc1 loc2 in PipeCond (loc, PipeSequence, pipe1, pipe2), loc } | pipe TokAnd pipe { let pipe1, loc1 = $1 in let pipe2, loc2 = $3 in let loc = union_loc loc1 loc2 in PipeCond (loc, PipeAnd, pipe1, pipe2), loc } | pipe TokOr pipe { let pipe1, loc1 = $1 in let pipe2, loc2 = $3 in let loc = union_loc loc1 loc2 in PipeCond (loc, PipeOr, pipe1, pipe2), loc } | pipe TokPipe pipe { let pipe1, loc1 = $1 in let pipe2, loc2 = $3 in let loc = union_loc loc1 loc2 in PipeCompose (loc, false, pipe1, pipe2), loc } | pipe TokPipe TokAmp pipe %prec TokPipe { let pipe1, loc1 = $1 in let pipe2, loc2 = $4 in let loc = union_loc loc1 loc2 in PipeCompose (loc, true, pipe1, pipe2), loc } | pipe TokAmp { let pipe, loc1 = $1 in let _, loc2 = $2 in let loc = union_loc loc1 loc2 in PipeBackground (loc, pipe), loc } | TokLeftParen pipe TokRightParen { let _, loc1 = $1 in let _, loc2 = $3 in let loc = union_loc loc1 loc2 in let pipe, _ = $2 in let group = { group_stdin = RedirectNone; group_stdout = RedirectNone; group_stderr = false; group_append = false; group_pipe = pipe } in PipeGroup (loc, group), loc } | pipe TokLessThan word { let pipe, loc1 = $1 in let file, loc2 = $3 in let loc = union_loc loc1 loc2 in let pipe = set_stdin pipe file in pipe, loc } | pipe TokGreaterThan word { let pipe, loc1 = $1 in let file, loc2 = $3 in let loc = union_loc loc1 loc2 in let pipe = set_stdout pipe file false false in pipe, loc } | pipe TokGreaterGreaterThan word { let pipe, loc1 = $1 in let file, loc2 = $3 in let loc = union_loc loc1 loc2 in let pipe = set_stdout pipe file false true in pipe, loc } | pipe TokGreaterThan TokAmp word %prec TokGreaterThan { let pipe, loc1 = $1 in let file, loc2 = $4 in let loc = union_loc loc1 loc2 in let pipe = set_stdout pipe file true false in pipe, loc } | pipe TokGreaterGreaterThan TokAmp word %prec TokGreaterGreaterThan { let pipe, loc1 = $1 in let file, loc2 = $4 in let loc = union_loc loc1 loc2 in let pipe = set_stdout pipe file true true in pipe, loc } ; /* * A command is just a sequence of words. */ command: rev_command { let rev_argv, loc = $1 in let command = command_of_values (List.rev rev_argv) loc in command, loc } ; rev_command: word { let values, loc = $1 in [values], loc } | rev_command word { let values1, loc1 = $1 in let values2, loc2 = $2 in values2 :: values1, union_loc loc1 loc2 } ; /* * A word is just a core set of values. */ word: TokValues { $1 } ; omake-0.10.3/src/shell/omake_shell_lex.mli0000644000175000017500000000075513177364666017101 0ustar gerdgerd(* * Lex a shell line. *) open Lm_glob open Omake_shell_type open Omake_command_type open! Omake_value_type (* * Commands with a leading \ are quoted. *) val parse_command_string : string -> simple_exe (* * Construct the pipe from the value. *) val pipe_of_value : Omake_env.t -> (Omake_env.t -> pos -> Lm_location.t -> string -> (Lm_symbol.t * Omake_env.apply) option) -> glob_options -> pos -> Lm_location.t -> Omake_value_type.t -> command_flag list * Omake_env.arg_pipe omake-0.10.3/src/shell/omake_shell_job.mli0000644000175000017500000000227413177364666017061 0ustar gerdgerd(** Shell execution. *) (** Create a thread or process running the function. *) val create_thread : Omake_env.t -> (Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> int) -> Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> Omake_env.pid (** Start a job given a pipe specification. *) val create_job : Omake_env.t -> Omake_env.string_pipe -> Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> Omake_env.t * Omake_value_type.t (** Create a process in the background. *) val create_process : Omake_env.t -> Omake_env.string_pipe -> Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> Omake_env.pid val waitpid : Omake_env.t -> Omake_value_type.pos -> Omake_env.pid -> int * Unix.process_status * Omake_value_type.t (** Shell operations. *) val jobs : Omake_env.t -> unit val bg : Omake_env.t -> Omake_value_type.pos -> int -> unit val fg : Omake_env.t -> Omake_value_type.pos -> int -> unit val stop : Omake_env.t -> Omake_value_type.pos -> int -> unit val kill : Omake_env.t -> Omake_value_type.pos -> int -> Omake_shell_type.signal -> unit val wait : Omake_env.t -> Omake_value_type.pos -> int -> unit val cleanup : Omake_env.t -> unit omake-0.10.3/src/shell/omake_shell_sys.mli0000644000175000017500000000472113177364666017124 0ustar gerdgerd(* * Architecture-independent process management. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004 Mojave Group, Caltech * * 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; version 2 * of the License. * * 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, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * * Additional permission is given to link this library with the * with the Objective Caml runtime, and to redistribute the * linked executables. See the file LICENSE.OMake for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) open Omake_shell_sys_type open Omake_shell_type (* * Set whether we are in interactive mode. * Defaults to true. *) val set_interactive : bool -> unit (* * Set the process group for the current terminal. * Does nothing if there is no terminal, or the * session is not interactive. *) val set_tty_pgrp : pgrp -> unit (* * Send a signal to a process. *) val kill : pgrp -> signal -> unit (* * Set/clear the close on exec flags. *) val close_fd : Unix.file_descr -> unit val set_close_on_exec : Unix.file_descr -> unit val clear_close_on_exec : Unix.file_descr -> unit (* * Wait: * wait pgrp leader nohang * pgrp: if 0, wait for all groups * otherwise, wait for the specific group * leader: if true, wait only for process group leaders * if false, wait only for process group children * nohang: if true, do not block * may raise Not_found * if false, block until something happens *) val wait : pgrp -> bool -> bool -> pid * Unix.process_status (* * Create a thread or a process executing the function. * Note, the called thread should close the channels it is passed. *) val create_thread : create_thread -> pid (* * Create an actual process. *) val create_process : create_process -> pid (* * -*- * Local Variables: * End: * -*- *) omake-0.10.3/src/shell/omake_shell_completion.mli0000644000175000017500000000035713177364666020460 0ustar gerdgerd (* * Set the command completion fur use by readline. * This should be called before each call to realine, * or after each shell prompt. *) val set_completion_functions : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> unit omake-0.10.3/src/shell/omake_shell_spawn.mli0000644000175000017500000001044213177364666017433 0ustar gerdgerd(* This is the module for subprocess execution derived from OCamlnet. It is only meant for Unix. If available, it takes advantage from the posix_spawn call. Copyright (C) 2014 by Gerd Stolpmann This file is licensed under the same conditions as omake. This work was sponsored by Lexifi. *) (** The following function has some similarity with posix_spawn, but is extended to our needs, Only special (although frequent) cases are implemented with posix_spawn. *) type wd_spec = | Wd_keep (** Keep the current working directory in the spawned process *) | Wd_chdir of string (** Change to this directory in the spawned process *) | Wd_fchdir of Unix.file_descr (** Change to the directory which has been previously been opened *) type pg_spec = | Pg_keep (** The new process will be member of the same process group as this process *) | Pg_new_bg_group (** A new background process group is created, and the spawned process will be its single member *) | Pg_new_fg_group (** A new foreground process group is created, and the spawned process will be its single member *) | Pg_join_group of int (** The spawned process will be member of this process group *) type fd_action = | Fda_close of Unix.file_descr (** Close the descriptor *) | Fda_close_ignore of Unix.file_descr (** Close the descriptor but ignore [EBADF] errors *) | Fda_close_except of bool array (** Closes all descriptors except those for which [except.(k)] is true where [k = int_of_file_descr fd]. Descriptors outside the array index range are closed. *) | Fda_dup2 of Unix.file_descr * Unix.file_descr (** Duplicate the first descriptor to the second as [dup2] does *) type sig_action = | Sig_default of int (** Resets this signal to default behavior in the spawned process *) | Sig_ignore of int (** Ignores the signal in the spawned process *) | Sig_mask of int list (** Set the signal mask in the spawned process *) val spawn : ?chdir:wd_spec -> ?pg:pg_spec -> ?fd_actions:fd_action list -> ?sig_actions:sig_action list -> ?env:string array -> ?no_posix_spawn:bool -> string -> string array -> int (** [spawn cmd args]: Fork the process and exec [cmd] which gets the arguments [args]. On success, the PID of the new process is returned. This function does not wait for the completion of the process; use [Unix.waitpid] for this purpose. - [chdir]: If set, the new process starts with this working directory (this is done before anything else) - [pg]: If set, the new process will be a member of this process group - [fd_actions]: If set, these descriptor actions are executed sequentially - [sig_actions]: If set, these signal actions are executed sequentially - [env]: If set, the process gets this environment instead of the current one - [no_posix_spawn]: If set, the [posix_spawn] family of library functions is not used to spawn even if possible, and always a [fork/exec] approach is taken. This may be slower, but there is normally better error reporting. Any exceptions in the subprocess are detected, and reported. However, if [Fda_close_ignore] leads to [EBADF] for a descriptor, this error is ignored. If [pg=Pg_new_fg_group], one should include [Sig_ignore Sys.sigttou] in [sig_actions]. There are two implementations for [spawn]: One calls [fork] and [exec] directly, and one uses the [posix_spawn] family of library functions. The latter is faster on certain conditions, but this is very OS-specific. Some features are not supported by [posix_spawn] and will force that [fork/exec] is used: [Pg_new_fg_group], and [Sig_ignore]. However, note some implementations of [posix_spawn] also fall back to [fork/exec] internally for some combinations of flags, and it is hard to predict which spawn calls can actually be accelerated. The tendency, though, is that recent OS have sped up [posix_spawn] so far possible (e.g. by using [vfork] internally, or even by making [posix_spawn] a system call). *) omake-0.10.3/src/shell/omake_shell_parse.mli0000644000175000017500000000122613177364666017415 0ustar gerdgerdtype token = | TokEof of (Lm_location.t) | TokValues of (Omake_value_type.t list * Lm_location.t) | TokDefine of (string * Lm_location.t) | TokLeftParen of (string * Lm_location.t) | TokRightParen of (string * Lm_location.t) | TokLessThan of (string * Lm_location.t) | TokGreaterThan of (string * Lm_location.t) | TokGreaterGreaterThan of (string * Lm_location.t) | TokAmp of (string * Lm_location.t) | TokPipe of (string * Lm_location.t) | TokSemiColon of (string * Lm_location.t) | TokAnd of (string * Lm_location.t) | TokOr of (string * Lm_location.t) val prog : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Omake_env.value_pipe omake-0.10.3/src/libmojave/0000755000175000017500000000000013177364666014075 5ustar gerdgerdomake-0.10.3/src/libmojave/OMakefile0000644000175000017500000000234413177364665015656 0ustar gerdgerd if $(THREADS_ENABLED) lm_thread_core.ml: lm_thread_core_system.ml ln-or-cp $< $@ lm_thread_pool.ml: lm_thread_pool_system.ml ln-or-cp $< $@ else lm_thread_core.ml: lm_thread_core_null.ml ln-or-cp $< $@ lm_thread_pool.ml: lm_thread_pool_null.ml ln-or-cp $< $@ OCamlGeneratedFiles(lm_thread_pool.ml lm_thread_core.ml) FILES[] = lm_printf lm_debug lm_heap lm_list_util lm_array_util lm_set_sig lm_set lm_map_sig lm_map lm_int_set lm_termsize lm_terminfo lm_arg lm_index lm_thread_sig lm_thread_core lm_thread lm_string_util lm_string_set # lm_hash_stat # lm_coarse_hash # lm_fine_hash lm_hash lm_hash_code lm_symbol lm_location lm_position lm_filename_util lm_uname lm_thread_pool lm_channel lm_unix_util lm_db lm_notify lm_fs_case_sensitive lm_wild lm_readline lm_marshal lm_handle_table lm_int_handle_table lm_bitset lm_instrument MakeOCamlLibrary(lm, $(FILES)) clean: $(CLEAN) MakeLinkFile(lm_thread_pool.ml, lm_thread_pool_$'$(system)'.ml) MakeLinkFile(lm_thread_core.ml, lm_thread_core_$'$(system)'.ml) MakeMakefile() omake-0.10.3/src/libmojave/lm_fs_case_sensitive.ml0000644000175000017500000001027113177364665020613 0ustar gerdgerd external case_sensitive_available : unit -> bool = "lm_fs_case_sensitive_available" external case_sensitive : string -> bool = "lm_fs_case_sensitive" let available = case_sensitive_available () (* Test whether stats are equal enough that we think that it's the same file.*) let stats_equal (stat1 : Unix.LargeFile.stats) (stat2 : Unix.LargeFile.stats) = stat1.st_dev = stat2.st_dev && stat1.st_ino = stat2.st_ino && stat1.st_kind = stat2.st_kind && stat1.st_rdev = stat2.st_rdev && stat1.st_nlink = stat2.st_nlink && stat1.st_size = stat2.st_size && stat1.st_mtime = stat2.st_mtime && stat1.st_ctime = stat2.st_ctime (* Stat, does not fail. *) let do_stat absname = try Some (Unix.LargeFile.lstat absname) with Unix.Unix_error _ -> None (* Unlink, does not fail. *) let do_unlink absname = try Unix.unlink absname with Unix.Unix_error _ -> () (* Create a file, raising Unix_error if the file can't be created. *) let do_create absname = Unix.close (Unix.openfile absname [O_WRONLY; O_CREAT; O_EXCL] 0o600) (* Given two filenames that differ only in case, stat them both. If the stats are different, the directory is on a case-sensitive fs. XXX: try to detect race conditions by performing a stat on the first file before and after. Raise Not_found if a race condition is detected. *) let stats_not_equal name1 name2 = let stat1 = do_stat name1 in let stat2 = do_stat name2 in let stat3 = do_stat name1 in match stat1, stat3 with Some s1, Some s3 when stats_equal s1 s3 -> (match stat2 with Some s2 when stats_equal s2 s1 -> false | _ -> true) | _ -> raise Not_found (* If we have an alphabetic name, just toggle the case.*) let stat_with_toggle_case absdir name : bool = (* Toggle the case of the name. Raises Not_found if the name contains no alphabetic letters. *) let rec toggle_name_case name len i : string = if i = len then raise Not_found else match name.[i] with | 'A'..'Z' (* | '\192' .. '\214' | '\216' .. '\222' *) -> String.lowercase_ascii name | 'a'..'z' (* | '\224' .. '\246' | '\248' .. '\254' *) -> String.uppercase_ascii name | _ -> toggle_name_case name len (i+ 1) in let alternate_name = toggle_name_case name (String.length name) 0 in stats_not_equal (Filename.concat absdir name) (Filename.concat absdir alternate_name) exception Already_lowercase let rec check_already_lowercase name len i = if i = len then raise Already_lowercase else match name.[i] with | 'A'..'Z' (* | '\192' .. '\214' | '\216' .. '\222' *) -> () | _ -> check_already_lowercase name len (i+1) (** Look through the entire directory for a name with alphabetic characters. A check for case-sensitivity base on that. Raises Not_found if there are no such filenames. *) let rec dir_test_all_entries_exn absdir dir_handle = match Unix.readdir dir_handle with | exception (Unix.Unix_error _ | End_of_file as exn) -> Unix.closedir dir_handle ; raise exn | "." | ".." -> dir_test_all_entries_exn absdir dir_handle | name -> match stat_with_toggle_case absdir name with | exception Not_found -> dir_test_all_entries_exn absdir dir_handle | result -> Unix.closedir dir_handle ; result let fs_random = Random.State.make_self_init () (* Check for sensativity by creating a dummy file. *) let dir_test_new_entry_exn absdir = Unix.access absdir [W_OK]; let name = Lm_printf.sprintf "OM%06x.tmp" (Random.State.bits fs_random land 0xFFFFFF) in let absname = Filename.concat absdir name in begin do_create absname ; match stat_with_toggle_case absdir name with | exception (Not_found as exn) -> do_unlink absname; raise exn | flag -> do_unlink absname; flag end exception Not_a_usable_directory let dir_case_sensitive absdir = match Unix.opendir absdir with | exception Unix.Unix_error ((ENOENT | ENOTDIR |ELOOP |ENAMETOOLONG), _, _) -> raise Not_a_usable_directory | dir_handle -> try dir_test_all_entries_exn absdir dir_handle with Unix.Unix_error _ | Not_found | End_of_file -> dir_test_new_entry_exn absdir omake-0.10.3/src/libmojave/lm_int_handle_table.ml0000644000175000017500000000422013177364665020370 0ustar gerdgerd module Table = Lm_int_set.IntTable type handle = int ref type 'a t = { mutable table_index : int; mutable table_entries : (handle * 'a) list Table.t } (************************************************ * Association lists. *) let replaceq entries key x = let rec loop entries1 entries2 = match entries2 with (key', _) :: entries2 when key' == key -> List.rev_append entries1 ((key, x) :: entries2) | h :: entries2 -> loop (h :: entries1) entries2 | [] -> (key, x) :: entries in loop [] entries let rec assq_value entries x = match entries with (key, x') :: _ when x' == x -> key | _ :: _ -> assq_value entries x | [] -> raise Not_found (************************************************ * Handle operations. *) let create_handle table index = let index2 = table.table_index in table.table_index <- max (index + 1) index2; ref index let new_handle table = let index = table.table_index in table.table_index <- succ index; ref index let int_of_handle = (!) (************************************************ * Table operations. *) let create () = { table_index = 0; table_entries = Table.empty } let add table hand x = let entries = Table.filter_add table.table_entries !hand (fun entries -> let entries = match entries with Some entries -> entries | None -> [] in replaceq entries hand x) in table.table_entries <- entries let remove table hand = let entries = Table.filter_remove table.table_entries !hand (fun entries -> let entries = List.remove_assq hand entries in match entries with [] -> None | _ :: _ -> Some entries) in table.table_entries <- entries let find table hand = List.assq hand (Table.find table.table_entries !hand) let find_any table hand = match Table.find table.table_entries !hand with (_, x) :: _ -> x | [] -> raise Not_found let find_any_handle table index = match Table.find table.table_entries index with (hand, _) :: _ -> hand | [] -> raise Not_found let find_value table index x = assq_value (Table.find table.table_entries index) x omake-0.10.3/src/libmojave/lm_filename_util.ml0000644000175000017500000003346113177364665017742 0ustar gerdgerd(* * Utilities on filenames. *) type pathname = string list (* * Tests for whether a file is executable. *) let euid = try Unix.geteuid () with Unix.Unix_error _ -> 0 let groups = try Array.to_list (Unix.getgroups ()) with Unix.Unix_error _ -> [] let unix_is_executable s = let flag = try let { Unix.LargeFile.st_kind = kind; Unix.LargeFile.st_perm = perm; Unix.LargeFile.st_uid = uid; Unix.LargeFile.st_gid = gid; _ } = Unix.LargeFile.stat s in (kind = Unix.S_REG) && ((perm land 0o001) <> 0 || (List.mem gid groups && (perm land 0o010) <> 0) || (uid = euid && (perm land 0o100) <> 0)) with Unix.Unix_error _ -> false in if flag then Some s else None (* * On Windows, the file does not have the be executable, * it just has to exist. *) let win32_suffixes = [""; ".com"; ".exe"; ".bat"; ".cmd"] let win32_is_executable = let rec search_win32 suffixes name = match suffixes with suffix :: suffixes -> let name' = name ^ suffix in if Sys.file_exists name' then Some name' else search_win32 suffixes name | [] -> None in search_win32 win32_suffixes (* * Cygwin is weird. See http://cygwin.com/cygwin-ug-net/using-specialnames.html#id4745135 * and http://bugzilla.metaprl.org/show_bug.cgi?id=496#c11 *) let cygwin_is_executable name = match unix_is_executable (name ^ ".exe") with Some _ as res -> res | None -> begin match unix_is_executable name with Some _ as res' -> res' | None -> None end (* * System-dependent config. * On win32, use lowercase names, and watch for drive letters. *) let has_drive_letters, normalize_string, normalize_path, search_separator_char, is_executable = match Sys.os_type with | "Win32" -> true, String.lowercase_ascii, List.map String.lowercase_ascii, ';', win32_is_executable | "Cygwin" -> false, String.lowercase_ascii, List.map String.lowercase_ascii, ':', cygwin_is_executable | "Unix" -> false, (fun s -> s), (fun s -> s), ':', unix_is_executable | s -> raise (Invalid_argument ("Omake_node: unknown system type " ^ s)) let separator_string = Filename.dir_sep (* TODO Mantis ticket to *) let separator_char = separator_string.[0] let search_separator_string = String.make 1 search_separator_char (* * Utilities for splitting paths. *) (* %%MAGICBEGIN%% *) type root = | NullRoot | DriveRoot of char type 'a path = | RelativePath of 'a | AbsolutePath of root * 'a (* %%MAGICEND%% *) let null_root = NullRoot (* * Windows sucks. Here are some utilities to * analyze drve letters. *) let is_drive_letter c = match c with |'a'..'z' |'A'..'Z' -> true | _ -> false let drive_skip name = let len = String.length name in if has_drive_letters && len >= 2 && is_drive_letter name.[0] && name.[1] = ':' then 2 else 0 let is_slash c = match c with '/' | '\\' -> true | _ -> false let is_absolute name = let len = String.length name in (len >= 3 && is_drive_letter name.[0] && name.[1] = ':' && is_slash name.[2]) || (len >= 1 && is_slash name.[0]) (* * Print the drive letter. *) let string_of_root = function NullRoot -> separator_string | DriveRoot c -> let s = Bytes.make 3 c in Bytes.set s 1 ':'; Bytes.set s 2 separator_char; Bytes.to_string s (* * Unescape a possibly quoted filename. * The only things we unquote are quotations. *) let unescape_string s = let len = String.length s in let rec start i = if i = len then s else match String.unsafe_get s i with '"' -> let buf = Buffer.create len in Buffer.add_substring buf s 0 i; dquote buf (succ i) | '\'' -> let buf = Buffer.create len in Buffer.add_substring buf s 0 i; squote buf (succ i) | _ -> start (succ i) and dquote buf i = if i = len then Buffer.contents buf else match String.unsafe_get s i with '"' -> normal buf (succ i) | '\\' when i < len - 1 -> (match s.[i + 1] with '"' -> Buffer.add_char buf '"'; dquote buf (i + 2) | _ -> Buffer.add_char buf '\\'; dquote buf (succ i)) | c -> Buffer.add_char buf c; dquote buf (succ i) and squote buf i = if i = len then Buffer.contents buf else match String.unsafe_get s i with '\'' -> normal buf (succ i) | '\\' when i < len - 1 -> (match s.[i + 1] with '\'' -> Buffer.add_char buf '\''; dquote buf (i + 2) | _ -> Buffer.add_char buf '\\'; dquote buf (succ i)) | c -> Buffer.add_char buf c; dquote buf (succ i) and normal buf i = if i = len then Buffer.contents buf else match String.unsafe_get s i with '"' -> dquote buf (succ i) | '\'' -> squote buf (succ i) | c -> Buffer.add_char buf c; normal buf (succ i) in start 0 (* * Split the path into root part, and the rest. *) let filename_string name = let len = String.length name in if has_drive_letters && len >= 3 && is_drive_letter name.[0] && name.[1] = ':' && (name.[2] = '/' || name.[2] = '\\') then let root = DriveRoot (Char.lowercase_ascii name.[0]) in let path = String.sub name 3 (len - 3) in AbsolutePath (root, path) else if len >= 1 && name.[0] = '/' then let root = NullRoot in let path = String.sub name 1 (len - 1) in AbsolutePath (root, path) else RelativePath name (* * Be careful not to split on glob characters. *) (* let is_glob_char s i = *) (* match String.unsafe_get s i with *) (* '{' | '}' | '*' | '?' | '[' | ']' -> *) (* true *) (* | _ -> *) (* false *) (* let filename_split name = *) (* let len = String.length name in *) (* let rec collect path off i = *) (* if i = len then *) (* let path = *) (* if i <= succ off then *) (* path *) (* else *) (* String.sub name off (i - off) :: path *) (* in *) (* List.rev path *) (* else *) (* let c = String.unsafe_get name i in *) (* match c with *) (* '/' -> *) (* if i <= succ off then *) (* collect path i (succ i) *) (* else *) (* collect (String.sub name off (i - off) :: path) i (succ i) *) (* | '\\' -> *) (* if i < len - 1 && is_glob_char name (succ i) then *) (* collect path off (i + 2) *) (* else if i <= succ off then *) (* collect path i (succ i) *) (* else *) (* collect (String.sub name off (i - off) :: path) i (succ i) *) (* | _ -> *) (* collect path off (succ i) *) (* in *) (* collect [] 0 0 *) (* * Split the rest into parts. *) let filename_path name = match filename_string name with AbsolutePath (root, path) -> AbsolutePath (root, Lm_string_util.split "\\/" path) | RelativePath path -> RelativePath (Lm_string_util.split "\\/" path) (* * Split a filename into root/suffix. *) let split name = try let index = String.rindex name '.' in let len = String.length name in let root = String.sub name 0 index in let suffix = String.sub name index (len - index) in root, suffix with Not_found -> name, "" (* * Separate this for efficiency. *) let root name = try let index = String.rindex name '.' in String.sub name 0 index with Not_found -> name let suffix name = try let index = String.rindex name '.' in String.sub name index (String.length name - index) with Not_found -> "" let strip_suffixes name = let start = try String.rindex name '/' with Not_found -> try String.rindex name '\\' with Not_found -> 0 in try let index = String.index_from name start '.' in String.sub name 0 index with Not_found -> name let separators = "/\\" (* Path separator. *) let pathsep = if Sys.os_type = "Win32" then ";" else ":" (* * Split a pathname. *) let split_path = Lm_string_util.split separators (* * Put it back together. *) let concat_path = String.concat separator_string (* * Basic file operations. *) let basename s = try let i = Lm_string_util.rindex_set s separators + 1 in String.sub s i (String.length s - i) with Not_found -> s let replace_basename s1 s2 = try let i = Lm_string_util.rindex_set s1 separators in Filename.concat (String.sub s1 0 i) s2 with Not_found -> s2 (* * Simplify, remove leading directory. *) let simplify_path path = let rec simplify path' = function | dir::tl -> if dir = "" || dir = "." then simplify path' tl else if dir = ".." then match path' with [] -> simplify path' tl | _::path'' -> simplify path'' tl else simplify (dir :: path') tl | [] -> List.rev path' in simplify [] path (* * Path searching. *) let search_table = Hashtbl.create 19 (* * Get the system path. *) let search_path = let path = try Sys.getenv "PATH" with Not_found -> "." in let path = Lm_string_util.split search_separator_string path in List.filter (fun name -> not (Filename.is_relative name)) path (* * Search for the file in the path. * Win32 files do not need to be executable. *) let search_command name = let rec search dirs name = match dirs with dir :: dirs -> let pathname = Filename.concat dir name in (match is_executable pathname with Some pathname -> pathname | None -> search dirs name) | [] -> raise Not_found in search search_path name (* * Figure out where in the path the commands comes from. *) let which name = if Filename.is_relative name then if Lm_string_util.contains_any name separators then let name = Filename.concat (Sys.getcwd ()) name in match is_executable name with Some fullname -> fullname | None -> raise Not_found else try Hashtbl.find search_table name with Not_found -> let fullname = search_command name in Hashtbl.add search_table name fullname; fullname else match is_executable name with Some fullname -> fullname | None -> raise Not_found (* * Use the directory as the starting point for relative names. *) let which_dir dir name = if Filename.is_relative name then if Lm_string_util.contains_any name separators then let name = Filename.concat dir name in match is_executable name with Some fullname -> fullname | None -> raise Not_found else try Hashtbl.find search_table name with Not_found -> let fullname = search_command name in Hashtbl.add search_table name fullname; fullname else match is_executable name with Some fullname -> fullname | None -> raise Not_found (* * Figure out where in the path the commands comes from. * Return all matches in order. *) let where name = if Lm_string_util.contains_any name separators then raise (Invalid_argument "Lm_filename_util.where"); let path = try Sys.getenv "PATH" with Not_found -> "." in let path = Lm_string_util.split search_separator_string path in let find dir = is_executable (Filename.concat dir name) in Lm_list_util.some_map find path (* * Make a directory hierarchy. *) let mkdirhier dir mode = let rec mkdir dir path = match path with | head :: path -> let dir = Filename.concat dir head in let () = try let s = Unix.LargeFile.stat dir in if s.st_kind <> S_DIR then raise (Unix.Unix_error (Unix.ENOTDIR, "Lm_filename_util.mkdirhier", dir)) with Unix.Unix_error (Unix.ENOENT, _, _) -> try Unix.mkdir dir mode with Unix.Unix_error (Unix.EEXIST, _, _) -> () in mkdir dir path | [] -> () in let path = filename_path dir in let top, path = match path with AbsolutePath (root, path) -> string_of_root root, path | RelativePath path -> ".", path in mkdir top path omake-0.10.3/src/libmojave/lm_handle_table.ml0000644000175000017500000000135513177364665017524 0ustar gerdgerd(* * Table indexed by opaque handles. *) (* * Handles. These need to be heap allocated so that we can register * finalization functions. *) type 'a t = { mutable table : 'a Lm_int_set.IntTable.t; mutable index : int } (* This must be heap-allocated *) type handle = { index : int } let create () = { table = Lm_int_set.IntTable.empty; index = 0 } let free table hand = table.table <- Lm_int_set.IntTable.remove table.table hand.index let add (table : 'a t) (x : 'a) = let i = table.index in let hand = { index = i } in Gc.finalise (free table) hand; table.index <- succ i; table.table <- Lm_int_set.IntTable.add table.table i x; hand let find table hand = Lm_int_set.IntTable.find table.table hand.index omake-0.10.3/src/libmojave/lm_string_util.ml0000644000175000017500000011505013177364665017463 0ustar gerdgerd (* * Show the file loading. *) let debug_string = Lm_debug.create_debug (**) { debug_name = "string"; debug_description = "check string bounds"; debug_value = false } let code0 = Char.code '0' (** Efficient string ordering (_not_ lexicographic) *) let rec string_compare_aux s1 s2 len i = if len = i then 0 else let c1 = String.unsafe_get s1 i in let c2 = String.unsafe_get s2 i in if c1 = c2 then string_compare_aux s1 s2 len (i+1) else Pervasives.compare c1 c2 let string_compare s1 s2 = let len1 = String.length s1 in match Pervasives.compare len1 (String.length s2) with 0 -> string_compare_aux s1 s2 len1 0 | i -> i (* * String prefix. *) let rec is_string_prefix_aux s1 s2 i len = i = len || (String.unsafe_get s1 i = String.unsafe_get s2 i && is_string_prefix_aux s1 s2 (i + 1) len) let is_string_prefix s1 s2 = let len1 = String.length s1 in let len2 = String.length s2 in len1 <= len2 && is_string_prefix_aux s1 s2 0 len1 (* * Compare a substring. *) let rec equal_substring_aux s1 s2 len2 i1 i2 = if i2 = len2 then true else let c1 = String.unsafe_get s1 i1 in let c2 = String.unsafe_get s2 i2 in c1 = c2 && equal_substring_aux s1 s2 len2 (succ i1) (succ i2) let equal_substring s1 off s2 = let len1 = String.length s1 in let len2 = String.length s2 in len1 - off >= len2 && equal_substring_aux s1 s2 len2 off 0 (* * Check all chars in the string. *) let for_all f s = let len = String.length s in let rec check i = (i = len) || (f s.[i] && check (succ i)) in check 0 (* * Find a char in a string. *) let strchr s c = let l = String.length s in let rec aux i = if i < l then if s.[i] = c then i else aux (succ i) else raise Not_found in aux 0 (* * A more efficient reimplementation of String.contains. *) let contains = let rec contains_aux s limit c i = (i < limit) && ((String.unsafe_get s i) = c || contains_aux s limit c (i+1)) in fun s c -> contains_aux s (String.length s) c 0 (* * contains_string s1 s2 * true iff any one of the characters in s2 appears in s1. *) let contains_any = let rec search2 s2 len2 c i = (i < len2) && ((String.unsafe_get s2 i) = c || search2 s2 len2 c (i + 1)) and search1 s1 len1 s2 len2 i = (i < len1) && (search2 s2 len2 (String.unsafe_get s1 i) 0 || search1 s1 len1 s2 len2 (i + 1)) in (fun s1 s2 -> search1 s1 (String.length s1) s2 (String.length s2) 0) (* * Index of first char in a set. *) let index_set s set = let len = String.length s in let rec loop i = if i = len then raise Not_found else let c = s.[i] in if String.contains set c then i else loop (succ i) in loop 0 let rindex_set s set = let rec loop i = if i < 0 then raise Not_found else let c = s.[i] in if String.contains set c then i else loop (i - 1) in loop (String.length s - 1) (* * Search for a pattern in the indicated buffer, within the start * and length constraints applied to the buffer. Note that this * uses a very inefficient algorithm; at some point I (JDS) will * get around to converting this to the Knuth-Morris-Pratt or * maybe Rabin-Karp algorithm. * * On success, this returns the offset (RELATIVE TO start!) of * the first match found; on failure, this raises Not_found. *) let strpat buffer start len pattern = let patlen = String.length pattern in let rec pattern_matches_prefix bufcur patcur = if patcur >= patlen then true else if buffer.[bufcur] <> pattern.[patcur] then false else pattern_matches_prefix (bufcur + 1) (patcur + 1) in let pattern_matches_prefix start = pattern_matches_prefix start 0 in let rec is_match start = if start + patlen > len then raise Not_found else if pattern_matches_prefix start then start else is_match (start + 1) in (is_match start) - start (* * Escape a string using SQL conventions. * Apparently, the only char we should escape is the single * quote, which is turned into 2 single quotes. *) let sql_escaped s = let len = String.length s in let buf = Buffer.create len in let rec loop i = if i = len then Buffer.contents buf else let c = s.[i] in if c = '\'' then Buffer.add_string buf "''" else Buffer.add_char buf c; loop (i + 1) in loop 0 let mysql_escaped s = let len = String.length s in let buf = Buffer.create len in let rec loop i = if i = len then Buffer.contents buf else let c = s.[i] in let _ = match c with '\000' -> Buffer.add_string buf "\\0" | '\'' -> Buffer.add_string buf "\\'" | '"' -> Buffer.add_string buf "\\\"" | '\n' -> Buffer.add_string buf "\\n" | '\r' -> Buffer.add_string buf "\\r" | '\t' -> Buffer.add_string buf "\\t" | '\\' -> Buffer.add_string buf "\\\\" | _ -> Buffer.add_char buf c in loop (succ i) in loop 0 (* * Escape a string using the C conventions. *) let c_escaped s = let len = String.length s in let buf = Buffer.create len in let rec loop i = if i = len then Buffer.contents buf else let c = s.[i] in let _ = match c with '\b' -> Buffer.add_string buf "\\b" | '\n' -> Buffer.add_string buf "\\n" | '\r' -> Buffer.add_string buf "\\r" | '\t' -> Buffer.add_string buf "\\t" | '\\' -> Buffer.add_string buf "\\\\" | _ -> if c >= ' ' && c <= '~' && c != '"' && c != '\'' then Buffer.add_char buf c else let code = Char.code c in Buffer.add_char buf '\\'; Buffer.add_char buf (Char.chr (((code / 64) mod 8) + code0)); Buffer.add_char buf (Char.chr (((code / 8) mod 8) + code0)); Buffer.add_char buf (Char.chr ((code mod 8) + code0)) in loop (succ i) in loop 0 (* * Escape a string using the Javascript single-quote conventions. *) let js_escaped s = let len = String.length s in let buf = Buffer.create len in let rec loop i = if i = len then Buffer.contents buf else let c = s.[i] in let _ = match c with '\'' -> Buffer.add_string buf "\\'" | '\\' -> Buffer.add_string buf "\\\\" | ' '..'~' -> Buffer.add_char buf c | _ -> let code = Char.code c in Buffer.add_char buf '\\'; Buffer.add_char buf (Char.chr (((code / 64) mod 8) + code0)); Buffer.add_char buf (Char.chr (((code / 8) mod 8) + code0)); Buffer.add_char buf (Char.chr ((code mod 8) + code0)) in loop (succ i) in loop 0 (* * Escape a string using the HTML conventions. *) let html_pre_escaped s = let len = String.length s in let buf = Buffer.create len in let rec loop i = if i = len then Buffer.contents buf else let c = s.[i] in let _ = match c with '<' -> Buffer.add_string buf "<" | '>' -> Buffer.add_string buf ">" | '&' -> Buffer.add_string buf "&" | '"' -> Buffer.add_string buf """ | ' ' | '\r' | '\n' | '\t' -> Buffer.add_char buf c | _ -> if c < ' ' || c >= '\127' then begin Buffer.add_string buf "&#"; Buffer.add_string buf (string_of_int (Char.code c)); Buffer.add_char buf ';' end else Buffer.add_char buf c in loop (succ i) in loop 0 let html_escaped s = let len = String.length s in let buf = Buffer.create len in let rec loop i = if i = len then Buffer.contents buf else let c = s.[i] in let _ = match c with '<' -> Buffer.add_string buf "<" | '>' -> Buffer.add_string buf ">" | '&' -> Buffer.add_string buf "&" | '"' -> Buffer.add_string buf """ | ' ' -> Buffer.add_string buf " " | '\r' -> () | '\n' -> Buffer.add_string buf "
\n"; | '\t' -> Buffer.add_string buf "    " | _ -> if c < ' ' || c >= '\127' then begin Buffer.add_string buf "&#"; Buffer.add_string buf (string_of_int (Char.code c)); Buffer.add_char buf ';' end else Buffer.add_char buf c in loop (succ i) in loop 0 (* * Escape a string using the HTML conventions. *) let html_escaped_nonwhite s = let len = String.length s in let buf = Buffer.create len in let rec loop i = if i = len then Buffer.contents buf else let c = s.[i] in let _ = match c with '<' -> Buffer.add_string buf "<" | '>' -> Buffer.add_string buf ">" | '&' -> Buffer.add_string buf "&" | '"' -> Buffer.add_string buf """ | ' ' | '\t' -> Buffer.add_char buf c | '\n' | '\r' -> Buffer.add_string buf "
\n" | _ -> if c < ' ' || c >= '\127' then begin Buffer.add_string buf "&#"; Buffer.add_string buf (string_of_int (Char.code c)); Buffer.add_char buf ';' end else Buffer.add_char buf c in loop (succ i) in loop 0 (* * A generic definition of white space. *) let white = " \t\r\n\012" let quotes = "\"'" (* * Test if a string is all whitespace. *) let is_white = let rec test s i len = i = len || (match String.unsafe_get s i with ' ' | '\t' | '\r' | '\n' | '\012' -> test s (succ i) len | _ -> false) in (fun s -> test s 0 (String.length s)) (* * Split a string str into a list of substrings. * The string is split on any character in delims. Empty substrings * are returned as empty strings in the list. For example: * split "-." "foo.bar--ba??z" * returns * ["foo"; "bar"; ""; "ba??z"] *) let split delims str = let strlen = String.length str in (* Find the next split index *) let rec next_split pos = if pos = strlen then strlen else let c = String.get str pos in if contains delims c then pos else next_split (pos + 1) in (* Build the list *) let rec str_split pos = let pos_end = next_split pos in if pos_end = strlen then [String.sub str pos (pos_end - pos)] else (String.sub str pos (pos_end - pos)) :: (str_split (pos_end + 1)) in str_split 0 let bi_split c s = let i = String.index s c in let l = String.length s in let v = String.sub s 0 i in let x = String.sub s (i + 1) (l - i - 1) in (v, x) (* * Split a string str into a list of substrings. * The string is split on any character in delims. Quotations * are not split. * * Empty substrings are _not_ returned as empty strings in the list. * For example: * split ".-" "foo.bar--ba??z" * returns * ["foo"; "bar"; "ba??z"] *) let tokens_fold f x quotes delims str = let strlen = String.length str in (* Skip white space *) let rec skip_split pos = if pos = strlen then strlen else let c = str.[pos] in if contains delims c then skip_split (succ pos) else pos in (* * Find the next split index. *) let rec next_split pos = if pos = strlen then strlen else let c = str.[pos] in if contains delims c then pos else if contains quotes c then next_quote (succ pos) else next_split (succ pos) and next_quote pos = if pos = strlen then strlen else let c = str.[pos] in if contains quotes c then next_split (succ pos) else if c = '\\' && pos < pred strlen then next_quote (pos + 2) else next_quote (succ pos) in (* Build the list *) let rec str_split x pos = if pos = strlen then x else let pos_end = next_split pos in let x = f x str pos (pos_end - pos) in str_split x (skip_split pos_end) in str_split x (skip_split 0) (* * Default token processor. *) let tokens quotes delims str = let l = tokens_fold (fun l s off len -> String.sub s off len :: l) [] quotes delims str in List.rev l let tokens_std s = tokens quotes white s (* * This is a somewhat optimized form of the above, * for parsing based on whitespace and normal quotes. * * For simple parsing, all the tokens_wrap_* functions are the same, * and the lexer is a dummy. *) type 'a tokens_prefix = NoPrefix | WordPrefix of 'a list | QuotePrefix of char * 'a list type 'a tokens = { tokens_lexer : (string -> int -> int -> int option); tokens_wrap_string : (string -> 'a); tokens_wrap_data : (string -> 'a); tokens_wrap_token : (string -> 'a); tokens_group : ('a list -> 'a); tokens_list : 'a list; tokens_prefix : 'a tokens_prefix } let tokens_create_lexer ~lexer ~wrap_string ~wrap_data ~wrap_token ~group = let group toks = match toks with [] -> wrap_data "" | [tok] -> tok | toks -> group (List.rev toks) in { tokens_lexer = lexer; tokens_wrap_string = wrap_string; tokens_wrap_data = wrap_data; tokens_wrap_token = wrap_token; tokens_group = group; tokens_list = []; tokens_prefix = NoPrefix } let tokens_create wrap group = tokens_create_lexer ~lexer:(fun _ _ _ -> None) ~wrap_string:wrap ~wrap_data:wrap ~wrap_token:wrap ~group:group (* * Get the tokens list. *) let tokens_flush info = let { tokens_group = group; tokens_list = tokens; tokens_prefix = prefix; _ } = info in let tokens = match prefix with NoPrefix -> tokens | WordPrefix prefix | QuotePrefix (_, prefix) -> group prefix :: tokens in List.rev tokens (* * End the current word. *) let tokens_break info = let { tokens_group = group; tokens_list = tokens; tokens_prefix = prefix; _ } = info in match prefix with NoPrefix -> info | WordPrefix prefix | QuotePrefix (_, prefix) -> { info with tokens_list = group prefix :: tokens; tokens_prefix = NoPrefix } (* * Add a value directly. * This also performs a break. *) let tokens_atomic info x = let { tokens_group = group; tokens_list = tokens; tokens_prefix = prefix; _ } = info in match prefix with NoPrefix -> { info with tokens_list = x :: tokens; tokens_prefix = NoPrefix } | WordPrefix prefix | QuotePrefix (_, prefix) -> { info with tokens_list = x :: group prefix :: tokens; tokens_prefix = NoPrefix } (* * Add an value that might be unwrapped. * The value is unwrapped only if it is not surrounded by whitespace. *) let tokens_add info x = match info.tokens_prefix with NoPrefix -> { info with tokens_prefix = WordPrefix [x] } | WordPrefix prefix -> { info with tokens_prefix = WordPrefix (x :: prefix) } | QuotePrefix (c, prefix) -> { info with tokens_prefix = QuotePrefix (c, x :: prefix) } (* * Insert literal data. * The data is not scanned for whitespace. *) let tokens_data info s = tokens_add info (info.tokens_wrap_data s) (* * Scan the string for whitespace. *) let tokens_string info s = let len = String.length s in let wrap = info.tokens_wrap_string in let wrap_prefix prefix s off len = if len <> 0 then wrap (String.sub s off len) :: prefix else prefix in (* Scanning whitespace *) let rec scan_white tokens i = if i = len then { info with tokens_list = tokens; tokens_prefix = NoPrefix } else match String.unsafe_get s i with ' ' | '\t' | '\n' | '\r' | '\012' -> scan_white tokens (succ i) | '"' | '\'' as c -> scan_quote tokens [] c i (succ i) | '\\' -> scan_word tokens [] i (i + 2) | _ -> scan_word tokens [] i (succ i) (* Scanning a quoted word *) and scan_quote tokens prefix delim start i = if i >= len then let head = wrap_prefix prefix s start (len - start) in { info with tokens_list = tokens; tokens_prefix = QuotePrefix (delim, head) } else let c = String.unsafe_get s i in match c with '"' | '\'' when c = delim -> scan_word tokens prefix start (succ i) | '\\' -> scan_quote tokens prefix delim start (i + 2) | _ -> scan_quote tokens prefix delim start (succ i) (* Scanning a word *) and scan_word tokens prefix start i = if i >= len then let prefix = wrap_prefix prefix s start (len - start) in { info with tokens_list = tokens; tokens_prefix = WordPrefix prefix } else match String.unsafe_get s i with ' ' | '\t' | '\n' | '\r' | '\012' -> let head = wrap_prefix prefix s start (i - start) in let head_tok = info.tokens_group head in scan_white (head_tok :: tokens) (succ i) | '"' | '\'' as c -> scan_quote tokens prefix c start (succ i) | '\\' -> scan_word tokens prefix start (i + 2) | _ -> scan_word tokens prefix start (succ i) in if len = 0 then info else let { tokens_list = tokens; tokens_prefix = prefix; _ } = info in match prefix with NoPrefix -> scan_white tokens 0 | WordPrefix prefix -> scan_word tokens prefix 0 0 | QuotePrefix (c, prefix) -> scan_quote tokens prefix c 0 0 (* * Yet another tokenizer, where we allow for special tokens. * This is used, for example, in shell parsing, where some * unquoted sequences like && are special. *) type buf_token = BufWhite | BufQuote of char | BufBackslash | BufChar | BufToken of int let buffer_get_quoted s i = match String.unsafe_get s i with ' ' | '\t' | '\n' | '\r' | '\012' -> BufWhite | '"' | '\'' as c -> BufQuote c | '\\' -> BufBackslash | _ -> BufChar let buffer_get_token lexer s i len = match String.unsafe_get s i with ' ' | '\t' | '\n' | '\r' | '\012' -> BufWhite | '"' | '\'' as c -> BufQuote c | '\\' -> BufBackslash | _ -> match lexer s i len with Some i -> BufToken i | None -> BufChar let tokens_lex info s = let { tokens_lexer = lexer; tokens_wrap_string = wrap_string; tokens_wrap_data = wrap_data; tokens_wrap_token = wrap_token; tokens_group = group; _ } = info in let len = String.length s in (* Don't add empty strings *) let wrap_data_prefix prefix s off len = if len <> 0 then wrap_data (String.sub s off len) :: prefix else prefix in let wrap_string_prefix prefix s off len = if len <> 0 then wrap_string (String.sub s off len) :: prefix else prefix in (* Scanning whitespace *) let rec scan_white tokens i = if i = len then { info with tokens_list = tokens; tokens_prefix = NoPrefix } else match buffer_get_token lexer s i len with | BufWhite -> scan_white tokens (succ i) | BufQuote c -> scan_quote tokens [] c (succ i) (succ i) | BufBackslash -> scan_word tokens [] i (i + 2) | BufChar -> scan_word tokens [] i (succ i) | BufToken len -> let head = wrap_token (String.sub s i len) in scan_white (head :: tokens) (i + len) (* Scanning a quoted word *) and scan_quote tokens prefix delim start i = if i >= len then let head = wrap_data_prefix prefix s start (len - start) in { info with tokens_list = tokens; tokens_prefix = QuotePrefix (delim, head) } else match buffer_get_quoted s i with | BufQuote c when c = delim -> let prefix = wrap_data_prefix prefix s start (i - start) in scan_word tokens prefix (succ i) (succ i) | BufBackslash -> scan_quote tokens prefix delim start (i + 2) | BufQuote _ | BufWhite | BufChar -> scan_quote tokens prefix delim start (succ i) | BufToken _ -> raise (Invalid_argument "Lm_string_util.tokens_lex: illegal token") (* Scanning a word *) and scan_word tokens prefix start i = if i >= len then let head = wrap_string_prefix prefix s start (len - start) in { info with tokens_list = tokens; tokens_prefix = WordPrefix head } else match buffer_get_token lexer s i len with | BufWhite -> let head = group (wrap_string_prefix prefix s start (i - start)) in scan_white (head :: tokens) (succ i) | BufToken len -> let head1 = group (wrap_string_prefix prefix s start (i - start)) in let head2 = wrap_token (String.sub s i len) in scan_white (head2 :: head1 :: tokens) (i + len) | BufQuote c -> let prefix = wrap_string_prefix prefix s start (i - start) in scan_quote tokens prefix c (succ i) (succ i) | BufBackslash -> scan_word tokens prefix start (i + 2) | BufChar -> scan_word tokens prefix start (succ i) in if len = 0 then info else let { tokens_list = tokens; tokens_prefix = prefix; _ } = info in match prefix with | NoPrefix -> scan_white tokens 0 | WordPrefix prefix -> scan_word tokens prefix 0 0 | QuotePrefix (c, prefix) -> scan_quote tokens prefix c 0 0 (* * Split a string based on a boundary. *) let split_string boundary s = let len_s = String.length s in let len_b = String.length boundary in let c = if len_b = 0 then raise (Invalid_argument "split_string"); boundary.[0] in let rec matches i j = if j = len_b then true else s.[i] = boundary.[j] && matches (succ i) (succ j) in let buf = Buffer.create 17 in let rec split l i = if len_s - i < len_b then begin Buffer.add_substring buf s i (len_s - i); Buffer.contents buf :: l end else if s.[i] = c && matches i 0 then let s' = Buffer.contents buf in Buffer.clear buf; split (s' :: l) (i + len_b) else begin Buffer.add_char buf s.[i]; split l (succ i) end in List.rev (split [] 0) (* * Split a string based on a MIME boundary. *) let split_mime_string boundary s = let len_s = String.length s in let len_b = String.length boundary in let rec matches i j = if j = len_b then true else s.[i] = boundary.[j] && matches (succ i) (succ j) in let buf = Buffer.create 17 in (* Collect the delimited text *) let rec split l i = if len_s - i < len_b - 2 then l else if s.[i] = '-' && s.[i + 1] = '-' && matches (i + 2) 0 then let l = Buffer.contents buf :: l in Buffer.clear buf; skip l (i + 2 + len_b) else begin Buffer.add_char buf s.[i]; split l (succ i) end (* Skip over garbage after the delimiter *) and skip l i = if len_s - i < 2 || (s.[i] = '-' && s.[i + 1] = '-') then l else split l (i + 2) (* Skip to the first delimiter *) and skip_start i = if len_s - i < len_b - 2 then [] else if s.[i] = '-' && s.[i + 1] = '-' && matches (i + 2) 0 then skip [] (i + 2 + len_b) else skip_start (succ i) in List.rev (skip_start 0) (* * Unescape a quoted string. *) let unescape s = let slen = String.length s in let buf = Buffer.create slen in let off, len = if slen < 2 then 0, slen else if s.[0] = '"' && s.[slen - 1] = '"' then 1, slen - 1 else 0, slen in let rec collect i = if i = len then Buffer.contents buf else let c = s.[i] in let c, i = if c = '\\' && i + 1 < len then match s.[i + 1] with | 't' -> '\t', i + 2 | 'r' -> '\r', i + 2 | 'n' -> '\n', i + 2 | '\\' -> '\\', i + 2 | ('0'..'9') when i + 3 < len -> let code = 100 * Char.code s.[i + 1] + 10 * Char.code s.[i + 2] + Char.code s.[i + 3] - 111 * Char.code '0' in Char.chr (code land 0xff), i + 4 | c -> c, i + 2 else c, i + 1 in Buffer.add_char buf c; collect i in collect off (* * Trim all whitespace from a string, respecting quotes. *) let trim_all quotes delims str = let scratch_buf = Buffer.create 17 in ignore (tokens_fold (fun first s off len -> if not first then Buffer.add_char scratch_buf ' '; Buffer.add_substring scratch_buf s off len; false) true quotes delims str); Buffer.contents scratch_buf let trim_std = trim_all quotes white (* * Trim outer whitespace from a string. *) let trim s = let length = String.length s in let is_whitespace = String.contains white in let rec scan_for_first_nonws index = if index < length && is_whitespace s.[index] then scan_for_first_nonws (index + 1) else index in let rec scan_for_last_nonws index = if index >= 0 && is_whitespace s.[index] then scan_for_last_nonws (index - 1) else index in let first = scan_for_first_nonws 0 in let last = scan_for_last_nonws (length - 1) in if first > last then "" else String.sub s first (last - first + 1) (* * Need these for converting numbers. *) let code0 = Char.code '0' let codea = Char.code 'a' let codeA = Char.code 'A' (* * Turn a string into an argument list. *) let parse_args_list line = let len = String.length line in let buf = Bytes.create len in let rec skip i = if i = len then [[]] else match line.[i] with | ' ' | '\t' | '\n' | '\r' -> skip (succ i) | '"' -> string 0 (succ i) | '\\' -> if len >= i + 2 && line.[i + 1] = '\\' then [] :: skip (i + 2) else raise (Invalid_argument ("Lm_string_util.parse_args: " ^ line)) | _ -> collect i (succ i) and collect i j = if j = len then [[String.sub line i (j - i)]] else match line.[j] with | ' ' | '\t' | '\n' | '\r' | '\\' -> let s = String.sub line i (j - i) in (match skip j with [] -> [[s]] | h :: tl -> (s :: h) :: tl) | _ -> collect i (succ j) and string j k = if k = len then raise (Invalid_argument ("Lm_string_util.parse_args: " ^ line)) else let c = line.[k] in if c = '"' then let s = Bytes.sub_string buf 0 j in match skip (succ k) with | [] -> raise (Invalid_argument "Lm_string_util.parse_args - internal error") | h::tl -> (s::h)::tl else if c = '\\' then escape j (succ k) else begin Bytes.set buf j c; string (succ j) (succ k) end and escape j k = if k = len then raise (Invalid_argument ("Lm_string_util.parse_args: " ^ line)) else let c,k = match line.[k] with | 't' -> '\t', succ k | 'n' -> '\n', succ k | 'r' -> '\r', succ k | '\\' -> '\\', succ k | ('0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9') as c -> Char.chr (100 * (Char.code c) + 10 * (Char.code line.[succ k]) + (Char.code line.[k+2]) - 111 * code0), k+3 | c -> c, succ k in Bytes.set buf j c; string (succ j) k in let _ = if !debug_string then Format.eprintf "Lm_string_util.parse_args: %s@." (String.escaped line) in let args = skip 0 in if !debug_string then Format.eprintf "Lm_string_util.parse_args: done@."; args let parse_args s = match parse_args_list s with [] -> [] | [l] -> l | _ -> raise (Invalid_argument ("Lm_string_util.parse_args - line includes \\\\:" ^ s)) (* * Concatenate strings. *) let prepend sep sl = let scratch_buf = Buffer.create 17 in let collect s = Buffer.add_string scratch_buf sep; Buffer.add_string scratch_buf s in Buffer.clear scratch_buf; if sl = [] then Buffer.add_string scratch_buf sep else List.iter collect sl; Buffer.contents scratch_buf (* * Read a file into a string. *) let string_of_file name = let inx = open_in_bin name in let scratch_buf = Buffer.create 17 in let rec loop () = Buffer.add_char scratch_buf (input_char inx); loop () in Buffer.clear scratch_buf; try loop () with | End_of_file -> close_in inx; let s = Buffer.contents scratch_buf in Buffer.reset scratch_buf; s (************************************************************************ * DEBUG VERSIONS ************************************************************************) (* * Create a new string containing garbage. *) (* let create name i = if !debug_string then if i < 0 then begin Format.eprintf "Lm_string_util.create: %s: %d < 0@." name i; raise (Failure "Lm_string_util.create") end; String.create i *) (* * Make a string initialized with all chars the same. *) let make name i c = if !debug_string then if i < 0 then begin Format.eprintf "Lm_string_util.make: %s: %d < 0@." name i; raise (Failure "Lm_string_util.make") end; String.make i c (* * Substring. *) let sub name s i len = if !debug_string then let len' = String.length s in if i >= 0 && len >= 0 && i + len < len' then String.sub s i len else begin Format.eprintf "Lm_string_util.sub error: %s: %s.[%d]@." name s i; raise (Failure "Lm_string_util.sub") end else String.sub s i len (* let blit name froms i tos j len = if !debug_string then let from_len = String.length froms in let to_len = String.length tos in if i >= 0 && j >= 0 && len >= 0 && i + len < from_len && j + len < to_len then String.blit froms i tos j len else begin Format.eprintf "String_util.blit_error: %s: %s %d %s %d %d@." name froms i tos j len; raise (Failure "String_util.blit") end else String.blit froms i tos j len *) (* let set name s i c = if !debug_string then let len = String.length s in if i >= 0 && i < len then String.set s i c else begin Format.eprintf "String_util.set error: %s: %s.[%d] <- %c@." name s i c; raise (Failure "String_util.set") end else String.set s i c *) let get name s i = let len = String.length s in if i >= 0 && i < len then String.get s i else begin Format.eprintf "String_util.get error: %s: %s[%d]@." name s i; raise (Failure "String_util.get") end (************************************************************************ * Hex notation. *) (* * Turn a string into hex. *) let hex_char = let zero = Char.code '0' in let a = Char.code 'a' - 10 in let hex_char code = if code < 10 then Char.chr (code + zero) else Char.chr (code + a) in hex_char let hexify s = let len = String.length s in let buf = Bytes.create (2 * len) in for i = 0 to pred len do let code = Char.code s.[i] in Bytes.set buf (2 * i) (hex_char ((code lsr 4) land 15)); Bytes.set buf (2 * i + 1) (hex_char (code land 15)) done; Bytes.to_string buf let hexify_sub s off len = let buf = Bytes.create (2 * len) in for i = 0 to pred len do let code = Char.code s.[off + i] in Bytes.set buf (2 * i) (hex_char ((code lsr 4) land 15)); Bytes.set buf (2 * i + 1) (hex_char (code land 15)) done; Bytes.to_string buf let unhex i = match i with | '0' .. '9' -> (Char.code i) - code0 | 'a' .. 'f' -> (Char.code i) - codea + 10 | 'A' .. 'F' -> (Char.code i) - codeA + 10 | _ -> raise (Failure "unhexify") let unhexify s = let len = String.length s in if len mod 2 = 0 then let buf = Bytes.create (len / 2) in let rec unhexify i j = if j < len then begin Bytes.set buf i (Char.chr ((unhex s.[j]) * 16 + (unhex s.[succ j]))); unhexify (i + 1) (j + 2) end in unhexify 0 0; Bytes.to_string buf else raise (Failure "unhexify") let unhexify_int s = let len = String.length s in let rec unhexify index i = if i < len then unhexify (index * 16 + (unhex s.[i])) (succ i) else index in unhexify 0 0 (* * Construct an argv string with proper quoting. * * We are given a list of arguments that may or may not contain * whitespace or quotes. Quote them in a meaningful way before * parsing. *) type mode = ModeNormal | ModeDouble | ModeSingle let rec needs_quotes mode s i len = if i >= len then mode <> ModeNormal else match mode, s.[i] with | _, '\\' -> needs_quotes mode s (i + 2) len | ModeNormal, ' ' | ModeNormal, '\t' | ModeNormal, '\012' | ModeNormal, '\n' | ModeNormal, '\r' -> true | ModeNormal, '"' -> needs_quotes ModeDouble s (succ i) len | ModeNormal, '\'' -> needs_quotes ModeSingle s (succ i) len | ModeSingle, '\'' | ModeDouble, '"' -> needs_quotes ModeNormal s (succ i) len | _ -> needs_quotes mode s (succ i) len let needs_quotes s = let len = String.length s in len = 0 || needs_quotes ModeNormal s 0 len let dquote = '"' let equote = "\\\"" let quotify buf s = let len = String.length s in let rec copy i = if i <> len then let c = s.[i] in match c with | '"' -> Buffer.add_string buf equote; copy (succ i) | '\\' -> Buffer.add_char buf '\\'; if i < len - 1 then begin Buffer.add_char buf s.[i + 1]; copy (i + 2) end | _ -> Buffer.add_char buf c; copy (succ i) in Buffer.add_char buf dquote; copy 0; Buffer.add_char buf dquote let shell_quotes s = let buf = Buffer.create 32 in quotify buf s; Buffer.contents buf let quote buf s = if needs_quotes s then quotify buf s else Buffer.add_string buf s let rec concat_argv buf argv = match argv with | [arg] -> quote buf arg | arg :: argv -> quote buf arg; Buffer.add_char buf ' '; concat_argv buf argv | [] -> () let concat_argv argv = let buf = Buffer.create 32 in concat_argv buf argv; Buffer.contents buf (* * For string quoting. *) let rec concat_string buf argv = match argv with | [arg] -> Buffer.add_string buf arg | arg :: argv -> Buffer.add_string buf arg; Buffer.add_char buf ' '; concat_string buf argv | [] -> () let concat_string argv = match argv with | [arg] -> arg | _ :: _ -> let buf = Buffer.create 32 in concat_string buf argv; Buffer.contents buf | [] -> "" (* * This function adds quotes if needed. *) let string_argv argv = let s = concat_string argv in if needs_quotes s then let buf = Buffer.create 32 in quotify buf s; Buffer.contents buf else s (* * This function always adds quotes. *) let quote_string s = let len = String.length s in if needs_quotes s || (not (s.[0] = '"' && s.[len - 1] = '"' || s.[0] = '\'' && s.[len - 1] = '\'')) then let buf = Buffer.create 32 in quotify buf s; Buffer.contents buf else s let quote_argv argv = quote_string (concat_string argv) (************************************************************************ * Translate between URI enconding. *) (* * Convert two hex chars into a new 8-bit char. *) let unhex_char c1 c2 = let i1 = unhex c1 in let i2 = unhex c2 in Char.chr (i1 * 16 + i2) (* * Decode hex characters in the URI. *) let decode_hex_name uri = let len = String.length uri in let buf = Bytes.create len in let rec convert i j = if j = len then if i = len then Bytes.to_string buf else Bytes.sub_string buf 0 i else if uri.[j] = '+' then begin Bytes.set buf i ' '; convert (i + 1) (j + 1) end else if uri.[j] = '%' && j < len - 2 then begin Bytes.set buf i (unhex_char uri.[j + 1] uri.[j + 2]); convert (i + 1) (j + 3) end else begin Bytes.set buf i (uri.[j]); convert (i + 1) (j + 1) end in convert 0 0 (* * Encode a string into hex. *) let hex_char code = if code < 10 then Char.chr (code + Char.code '0') else Char.chr (code - 10 + Char.code 'a') let encode_hex_name uri = let len = String.length uri in let buf = Bytes.create (3 * len) in let rec convert i j = if i = len then Bytes.sub_string buf 0 j else match uri.[i] with | ('0'..'9' | 'A'..'Z' | 'a'..'z' | '/' | '_' | '-' | '.') as c -> Bytes.set buf j c; convert (succ i) (succ j) | c -> let code = Char.code c in Bytes.set buf j '%'; Bytes.set buf (j + 1) (hex_char ((code lsr 4) land 15)); Bytes.set buf (j + 2) (hex_char (code land 15)); convert (succ i) (j + 3) in convert 0 0 let fold_left f init str = let n = String.length str in let rec loop i result = if i = n then result else loop (i + 1) (f result str.[i]) in loop 0 init let fold_lefti f init str = let n = String.length str in let rec loop i result = if i = n then result else loop (i + 1) (f result i str.[i]) in loop 0 init let fold_right f str init = let n = String.length str in let rec loop i result = if i = 0 then result else let i' = i - 1 in loop i' (f str.[i'] result) in loop n init let fold_righti f str init = let n = String.length str in let rec loop i result = if i = 0 then result else let i' = i - 1 in loop i' (f i' str.[i'] result) in loop n init let iteri f str = for i = 0 to (String.length str) - 1 do f i str.[i] done omake-0.10.3/src/libmojave/lm_db.ml0000644000175000017500000002540513177364665015511 0ustar gerdgerd(* * Simple value database. The entries in the database have * the following format. * * - Field label (int) * - Hostname (string) * - Magic number (16 bytes) * - Digest (used on the source file, for up-to-date info) * - Value (marshaled) * * Invariant: * - There is at most one entry for each host/field label. * * If the magic number doesn't match, then the entry is * out-of-date, and should be replaced. * * In some cases, the hostname doesn't matter. Even so, if there * is an entry with the current hostname, and the magic number * doesn't match, it is out-of-date. * * NOTE: This has been updated to allowed for key-value pairs * in the header. It looks pretty dumb, but I (jyh) want to keep * the file format backward-compatible. So we stuff all the key/value * pairs in the magic number. *) open Lm_printf open Lm_debug let debug_db = create_debug (**) { debug_name = "db"; debug_description = "Display debugging information for marshaling operations"; debug_value = false } type t = Unix.file_descr type tag = int type magic = string type digest = string type hostname = string type named_value = string * string type entry_pred = tag -> named_value list -> hostname -> digest -> bool let first_entry_tag = 1000 (* * Some kinds of entries are host-independent. *) type host = HostIndependent | HostDependent (* * Codes during unmarshaling. *) type 'a unmarshal = UnmarshalValue of 'a | UnmarshalNext (* * Codes during removal. *) type remove = RemoveEntry of int | RemoveNext | RemoveRest (* * Version number. *) let magic = 0x56e50f8b (* * Marshaling. *) let hostname = Unix.gethostname () let digest_length = 16 (* * File operations. *) (* * Win32 doesn't have a general truncate, so seek and truncate. *) let seek_and_truncate fd pos = let _ = Unix.lseek fd pos Unix.SEEK_SET in Lm_unix_util.ftruncate fd (* * * When an entry is removed, copy the remaining parts of * the file. *) let bufsize = 4096 let file_shift fd pos1 pos2 = let buf = Bytes.create bufsize in let rec copy pos1 pos2 = let _ = Unix.lseek fd pos2 Unix.SEEK_SET in let amount = Unix.read fd buf 0 bufsize in if amount <> 0 then let _ = Unix.lseek fd pos1 Unix.SEEK_SET in assert (Unix.write fd buf 0 amount = amount); copy (pos1 + amount) (pos2 + amount) else pos1 in let pos = copy pos1 pos2 in seek_and_truncate fd pos; ignore (Unix.lseek fd pos1 Unix.SEEK_SET) (* * If some kind of error happens while removing an entry, * truncate the file at this point. *) let remove_entry fd pos off = try file_shift fd pos off with Unix.Unix_error _ -> seek_and_truncate fd pos (* * Unmarshaling. *) let unmarshal_magic inx = try input_binary_int inx = magic with End_of_file -> false let unmarshal_tag inx = input_binary_int inx let unmarshal_digest inx = let s = Bytes.create digest_length in really_input inx s 0 digest_length; Bytes.to_string s let unmarshal_string inx = let len = input_binary_int inx in if len < 0 || len >= 1024 then raise (Failure "unmarshal_string") else let s = Bytes.create len in really_input inx s 0 len; Bytes.to_string s let unmarshal_strings_old inx = let magic = unmarshal_string inx in ["MAGIC", magic] let unmarshal_strings_new inx = (* Total size of all the entries *) let _ = input_binary_int inx in (* Number of key/value pairs *) let len = input_binary_int inx in (* Read the key/value pairs *) if len < 0 || len >= 1024 then raise (Failure "unmarshal_string") else let rec loop strings i = if i = len then List.rev strings else let key = unmarshal_string inx in let value = unmarshal_string inx in loop ((key, value) :: strings) (i + 1) in loop [] 0 let unmarshal_strings inx tag = if tag < first_entry_tag then unmarshal_strings_old inx else unmarshal_strings_new inx (* * Search for the appropriate entry. *) let find_entry fd filename test = let _ = Unix.lseek fd 0 Unix.SEEK_SET in let inx = Unix.in_channel_of_descr fd in let head = Bytes.create Marshal.header_size in (* Find the appropriate entry *) let unmarshal_entry () = (* Get the header *) let tag = unmarshal_tag inx in let host = unmarshal_string inx in let strings = unmarshal_strings inx tag in let digest = unmarshal_digest inx in if test tag strings host digest then begin (* Found a matching entry *) if !debug_db then eprintf "@[Marshal.from_channel: %s@ save tag/digest: %d/%s@." (**) filename tag (Lm_string_util.hexify digest); let x = UnmarshalValue (Marshal.from_channel inx) in if !debug_db then eprintf "Marshal.from-channel: done@."; x end else (* Skip over this entry *) let () = really_input inx head 0 Marshal.header_size in let size = Marshal.data_size head 0 in let pos = pos_in inx + size in seek_in inx pos; UnmarshalNext in (* * Search through the entries. If an exception is raised, * truncate the file at the start of the entry. *) let rec search () = let start = pos_in inx in let code = try unmarshal_entry () with End_of_file | Failure _ | Sys_error _ | Invalid_argument _ -> if !debug_db then eprintf "Lm_db.find: %s: failed@." filename; seek_and_truncate fd start; raise Not_found in match code with UnmarshalValue x -> x | UnmarshalNext -> search () in if unmarshal_magic inx then search () else raise Not_found let find fd filename (tag, host_mode) magic digest = let test tag' strings host' digest' = match strings with ["MAGIC", magic'] -> tag' = tag && magic' = magic && digest' = digest && (host_mode = HostIndependent || host' = hostname) | _ -> false in find_entry fd filename test (* * Remove an entry. Search through the existing entries * to find one with the same tag. If the host is significant, * remove only the entry with the same hostname. Otherwise, * remove the entry with the same magic number. *) let marshal_magic fd = seek_and_truncate fd 0; let outx = Unix.out_channel_of_descr fd in output_binary_int outx magic; Pervasives.flush outx let remove_entry fd _filename test = let head = Bytes.create Marshal.header_size in (* Find the appropriate entry *) let unmarshal_entry inx = (* Get the header *) let tag = unmarshal_tag inx in let host = unmarshal_string inx in let strings = unmarshal_strings inx tag in let digest = unmarshal_digest inx in let () = really_input inx head 0 Marshal.header_size in let size = Marshal.data_size head 0 in let pos = pos_in inx + size in if test tag strings host digest then RemoveEntry pos else begin seek_in inx pos; RemoveNext end in (* * Search through the entries. If an exception is raised, * truncate the file at the start of the entry. *) let rec search inx = let start = pos_in inx in let code = try unmarshal_entry inx with End_of_file | Failure _ | Sys_error _ | Invalid_argument _ -> RemoveRest in match code with RemoveEntry pos -> remove_entry fd start pos; ignore(Unix.lseek fd 0 Unix.SEEK_SET); let inx = Unix.in_channel_of_descr fd in seek_in inx start; search inx | RemoveNext -> search inx | RemoveRest -> seek_and_truncate fd start in let _ = Unix.lseek fd 0 Unix.SEEK_SET in let inx = Unix.in_channel_of_descr fd in if unmarshal_magic inx then search inx else marshal_magic fd let remove fd filename (tag, host_mode) magic = let test tag' strings host' _digest' = match strings with ["MAGIC", magic'] -> tag' = tag && (host' = hostname || host_mode = HostIndependent && magic' = magic) | _ -> false in remove_entry fd filename test (* * Add an entry. * Remove any existing entry, and add the new one to the end of the * file. *) let marshal_tag outx tag = output_binary_int outx tag let marshal_digest outx digest = assert (String.length digest = digest_length); Pervasives.output_string outx digest let marshal_string outx s = let len = String.length s in output_binary_int outx len; Pervasives.output_string outx s let marshal_strings outx sl = let len = List.fold_left (fun len (key, value) -> len + String.length key + String.length value + 8) 4 sl in output_binary_int outx len; output_binary_int outx (List.length sl); List.iter (fun (key, value) -> marshal_string outx key; marshal_string outx value) sl let marshal_entry fd filename tag magic_number digest x = let outx = Unix.out_channel_of_descr fd in marshal_tag outx tag; marshal_string outx hostname; marshal_string outx magic_number; marshal_digest outx digest; if !debug_db then eprintf "@[Marshal.to_channel: %s@ tag/digest: %d/%s@]@." (**) filename tag (Lm_string_util.hexify digest); Marshal.to_channel outx x []; if !debug_db then eprintf "Marshal.to_channel: %s: done@." filename; Pervasives.flush outx let add fd filename ((code, _) as tag) magic digest x = remove fd filename tag magic; marshal_entry fd filename code magic digest x let append_entry fd filename tag strings digest x = let _ = Unix.lseek fd 0 Unix.SEEK_END in let outx = Unix.out_channel_of_descr fd in marshal_tag outx tag; marshal_string outx hostname; marshal_strings outx strings; marshal_digest outx digest; if !debug_db then eprintf "@[Marshal.to_channel: %s@ tag/digest: %d/%s@]@." (**) filename tag (Lm_string_util.hexify digest); Marshal.to_channel outx x []; if !debug_db then eprintf "Marshal.to_channel: %s: done@." filename; Pervasives.flush outx (* * -*- * Local Variables: * End: * -*- *) omake-0.10.3/src/libmojave/lm_map.ml0000644000175000017500000017076213177364665015710 0ustar gerdgerd(* * Build a table using a red-black tree. * Every node in the tree is colored either black or red. * A red-black tree has the following invariants: * 1. Every leaf is colored black * 2. All children of every red node are black. * 3. Every path from the root to a leaf has the * same number of black nodes as every other path. * 4. The root is always black. * * We get some corollaries: * 1. The longest path from the root to a leaf is * at most twice as long as the shortest path. * 2. Both children of a red node are either leaves, * or they are both not. * * This code is meant to be fast, so all the cases have * been expanded, and the insert and delete functions are * long (12 cases for insert, 18 for delete in lift_black). * *) open Lm_map_sig (* * Table is a binary tree. * Color is kept in the label to save space. *) (* %%MAGICBEGIN%% *) type ('elt, 'data) tree = Leaf | Red of 'elt * 'data * ('elt, 'data) tree * ('elt, 'data) tree * int | Black of 'elt * 'data * ('elt, 'data) tree * ('elt, 'data) tree * int (* %%MAGICEND%% *) (* * Make the set. *) module LmMake (Base : OrderedType) = struct (* * Path into the tree. *) type ('elt, 'data) path = Left of ('elt, 'data) tree | Right of ('elt, 'data) tree | Delete of ('elt, 'data) tree type key = Base.t type 'a t = (key, 'a) tree exception Unchanged (* * Size of a table. *) let cardinality = function Red (_, _, _, _, size) | Black (_, _, _, _, size) -> size | Leaf -> 0 let cardinal = cardinality (* * Add two nodes. *) let new_black key data left right = Black (key, data, left, right, cardinality left + cardinality right + 1) let new_red key data left right = Red (key, data, left, right, cardinality left + cardinality right + 1) (************************************************************************ * DEBUGGING * ************************************************************************) (* * Check the size of the set. *) (* let rec check_size = function *) (* Black (_, _, left, right, size) *) (* | Red (_, _, left, right, size) -> *) (* let lsize = check_size left in *) (* let rsize = check_size right in *) (* if size <> lsize + rsize + 1 then *) (* let msg = "Lm_map.check_size: " ^ (string_of_int size) ^ " <> " ^ *) (* (string_of_int lsize) ^ "+" ^ (string_of_int rsize) in *) (* raise (Failure msg) *) (* else *) (* size *) (* | Leaf -> *) (* 0 *) (* * Check the red-invariant. *) (* let rec check_red = function *) (* Red (_, _, left, right, _) -> *) (* begin *) (* match left, right with *) (* Red _, _ *) (* | _, Red _ -> *) (* raise (Failure "Red_black_table.red_black_set.check_red") *) (* | _ -> *) (* check_red left; *) (* check_red right *) (* end *) (* | Black (_, _, left, right, _) -> *) (* check_red left; *) (* check_red right *) (* | Leaf -> *) (* () *) (* * Check the black invariant. *) (* let rec black_depth i = function *) (* Black (_, _, left, _, _) -> *) (* black_depth (succ i) left *) (* | Red (_, _, left, _, _) -> *) (* black_depth i left *) (* | Leaf -> *) (* i *) (* let rec check_black_aux i j = function *) (* Black (_, _, left, right, _) -> *) (* check_black_aux i (succ j) left; *) (* check_black_aux i (succ j) right *) (* | Red (_, _, left, right, _) -> *) (* check_black_aux i j left; *) (* check_black_aux i j right *) (* | Leaf -> *) (* if j <> i then *) (* raise (Failure "Red_black_table.check_black") *) (* let check_black tree = *) (* check_black_aux (black_depth 0 tree) 0 tree *) (* * Check that all the nodes are sorted. *) (* let rec check_sort_lt key = function *) (* Black (key', _, left, right, _) -> *) (* if Base.compare key' key >= 0 then *) (* raise (Failure "Red_black_table.check_sort"); *) (* check_sort_lt key' left; *) (* check_sort_gt_lt key' key right *) (* | Red (key', _, left, right, _) -> *) (* if Base.compare key' key >= 0 then *) (* raise (Failure "Red_black_table.check_sort"); *) (* check_sort_lt key' left; *) (* check_sort_gt_lt key' key right *) (* | Leaf -> *) (* () *) (* and check_sort_gt key = function *) (* Black (key', _, left, right, _) *) (* | Red (key', _, left, right, _) -> *) (* if Base.compare key' key <= 0 then *) (* raise (Failure "Red_black_table.check_sort"); *) (* check_sort_gt_lt key key' left; *) (* check_sort_gt key right *) (* | Leaf -> *) (* () *) (* and check_sort_gt_lt key key' = function *) (* Black (key'', _, left, right, _) *) (* | Red (key'', _, left, right, _) -> *) (* if Base.compare key'' key <= 0 || Base.compare key'' key' >= 0 then *) (* raise (Failure "Red_black_table.check_sort"); *) (* check_sort_gt_lt key key'' left; *) (* check_sort_gt_lt key'' key' right *) (* | Leaf -> *) (* () *) (* let check_sort = function *) (* Black (key, _, left, right, _) -> *) (* check_sort_lt key left; *) (* check_sort_gt key right *) (* | Red _ -> *) (* raise (Failure "Red_black_table.check_sort: root is red") *) (* | Leaf -> *) (* () *) (* * Perform all the checks. *) (* let check tree = *) (* check_red tree; *) (* check_black tree; *) (* check_sort tree; *) (* ignore (check_size tree); *) (* tree *) (************************************************************************ * INSERTION * ************************************************************************) (* * Insert an entry into the tree. *) let rec insert (key : 'elt) (dataf : 'data option -> 'data) = function Black (key0, data0, left0, right0, size0) -> begin let comp = Base.compare key key0 in if comp = 0 then let data = dataf (Some data0) in if data == data0 then raise Unchanged; Black (key0, data, left0, right0, size0) else if comp < 0 then match left0 with Black _ | Leaf -> (* * Ok even if child becomes red. *) new_black key0 data0 (insert key dataf left0) right0 | Red (key1, data1, left1, right1, size1) -> let comp = Base.compare key key1 in if comp = 0 then Black (key0, data0, Red (key1, dataf (Some data1), left1, right1, size1), right0, size0) else if comp < 0 then match insert key dataf left1, right0 with Red _ as node, Red (key2, data2, left2, right2, size2) -> (* * Recoloring: * * key0:b key0:r * / \ / \ * key1:r key2:r key1:b key2:b * / \ / \ * key2:r right1 key2:r right1 *) new_red key0 data0 (**) (new_black key1 data1 node right1) (Black (key2, data2, left2, right2, size2)) | Red _ as node, _ -> (* * Rotation: * * key0:b key1:b * / \ / \ * key1:r key2:b key3:r key0:b * / \ / \ * key3:r right1 right1 key2:r *) new_black key1 data1 node (new_red key0 data0 right1 right0) | node, _ -> (* * Inline: * * key0:b key0:b * / \ / \ * key1:r key2 key1:r key2 * / \ / \ * key3:b right1 key3:b right1 *) new_black key0 data0 (**) (new_red key1 data1 node right1) right0 else match insert key dataf right1, right0 with Red _ as node, Red (key2, data2, left2, right2, size2) -> (* * Recoloring: * * key0:b key0:r * / \ / \ * key1:r key2:r key1:b key2:b * / \ / \ * left1 node:r left1 node:r *) new_red key0 data0 (**) (new_black key1 data1 left1 node) (Black (key2, data2, left2, right2, size2)) | Red (key3, data3, left3, right3, _), _ -> (* * Rotation: * * key0:b key3:b * / \ / \ * key1:r right0 key1:r key0:r * / \ / \ / \ * left1 key3:r left1 left3 right3 right0 * / \ * left3 right3 *) new_black key3 data3 (**) (new_red key1 data1 left1 left3) (new_red key0 data0 right3 right0) | node3, _ -> (* * Inline: * * key0:b * / \ * key1:r right0 * / \ * left1 node3:b *) new_black key0 data0 (**) (new_red key1 data1 left1 node3) right0 else (* comp > 0 *) match right0 with Black _ | Leaf -> (* * Node can be replaced even if it becomes red. *) new_black key0 data0 left0 (insert key dataf right0) | Red (key2, data2, left2, right2, size2) -> let comp = Base.compare key key2 in if comp = 0 then Black (key0, data0, left0, Red (key2, dataf (Some data2), left2, right2, size2), size0) else if comp < 0 then match left0, insert key dataf left2 with Red (key1, data1, left1, right1, size1), (Red _ as node) -> (* * Recoloring: * * key0:b key0:r * / \ / \ * key1:r key2:r key1:b key2:b * / \ / \ * node:r right2 node:r right2 *) new_red key0 data0 (**) (Black (key1, data1, left1, right1, size1)) (new_black key2 data2 node right2) | _, Red (key3, data3, left3, right3, _) -> (* * Rotate: * * key0:b key3:b * / \ / \ * key1:b key2:r key0:r key2:r * / \ / \ / \ * key3:r right2 left0 left3 right3 right2 * / \ * left3 right3 *) new_black key3 data3 (**) (new_red key0 data0 left0 left3) (new_red key2 data2 right3 right2) | _, node3 -> (* * Inline: * * key0:b * / \ * left0 key2:r * / \ * key3:b right2 *) new_black key0 data0 (**) left0 (new_red key2 data2 node3 right2) else match left0, insert key dataf right2 with Red (key1, data1, left1, right1, size1), (Red _ as node) -> (* * Recoloring: * * key0:b key0:r * / \ / \ * key1:r key2:r key1:b key2:b * / \ / \ * left2 node:r left2 node:r *) new_red key0 data0 (**) (Black (key1, data1, left1, right1, size1)) (new_black key2 data2 left2 node) | _, (Red _ as node) -> (* * Rotation: * * key0:b key2:b * / \ / \ * left0:b key2:r key0:r node:r * / \ / \ * left2 node:r left0:b left2 *) new_black key2 data2 (**) (new_red key0 data0 left0 left2) node | _, node3 -> (* * Inline: * * key0:b * / \ * left0:b key2:r * / \ * left2 node3:b *) new_black key0 data0 (**) left0 (new_red key2 data2 left2 node3) end | Leaf -> (* Leaf is colored red *) Red (key, dataf None, Leaf, Leaf, 1) | Red _ -> (* Red nodes will not come up *) raise (Invalid_argument "Red_black_table.insert") (* * Append an element to the list. *) let filter_add (tree : ('elt, 'data) tree) (key : 'elt) (dataf : 'data option -> 'data) = let tree = match tree with Leaf -> Black (key, dataf None, Leaf, Leaf, 1) | node -> try match insert key dataf node with Red (key, data, left, right, size) -> Black (key, data, left, right, size) | tree -> tree with Unchanged -> tree in (tree : ('elt, 'data) tree) (* * Like filter-add, but the value must already exist. *) let replace tree key dataf = filter_add tree key (fun x -> match x with Some x -> dataf x | None -> raise Not_found) (* * Add an element to the set. *) let add (tree : ('elt, 'data) tree) (key : 'elt) (data : 'data) = filter_add tree key (fun _ -> data) (************************************************************************ * FIND ENTRIES * ************************************************************************) (* * Return the data for the entry. *) let rec find_aux key = function Black (key0, data0, left0, right0, _) | Red (key0, data0, left0, right0, _) -> let comp = Base.compare key key0 in if comp = 0 then data0 else if comp < 0 then find_aux key left0 else find_aux key right0 | Leaf -> raise Not_found let find tree key = find_aux key tree (* * Return the data for the entry. *) let rec find_aux key = function Black (key0, data0, left0, right0, _) | Red (key0, data0, left0, right0, _) -> let comp = Base.compare key key0 in if comp = 0 then data0 else if comp < 0 then find_aux key left0 else find_aux key right0 | Leaf -> [] let find_all tree key = find_aux key tree (************************************************************************ * REMOVAL * ************************************************************************) (* * Construct a path during the removal. *) let rec delete key filter path node = match node with Black (key0, data0, left0, right0, size0) -> let comp = Base.compare key key0 in if comp = 0 then match filter data0 with None -> begin match left0, right0 with Leaf, Leaf -> lift_black (key0, data0) path Leaf | Red (key1, data1, left1, right1, size1), Leaf -> lift (key0, data0) path (Black (key1, data1, left1, right1, size1)) | _ -> delete_min (Delete node :: path) right0 end | Some data0 -> restore path (Black (key0, data0, left0, right0, size0)) else if comp < 0 then delete key filter (Left node :: path) left0 else delete key filter (Right node :: path) right0 | Red (key0, data0, left0, right0, size0) -> let comp = Base.compare key key0 in if comp = 0 then (* Dammit! The filter needs to be applied here too! -n8 *) match filter data0 with None -> begin (* This is all that was here before *) match right0 with Leaf -> lift (key0, data0) path Leaf | _ -> delete_min (Delete node :: path) right0 end | Some data0 -> restore path (Red (key0, data0, left0, right0, size0)) else if comp < 0 then delete key filter (Left node :: path) left0 else delete key filter (Right node :: path) right0 | Leaf -> raise Not_found and restore path node = match path with Left (Black (key0, data0, _, right0, size0)) :: path -> restore path (Black (key0, data0, node, right0, size0)) | Left (Red (key0, data0, _, right0, size0)) :: path -> restore path (Red (key0, data0, node, right0, size0)) | Right (Black (key0, data0, left0, _, size0)) :: path -> restore path (Black (key0, data0, left0, node, size0)) | Right (Red (key0, data0, left0, _, size0)) :: path -> restore path (Red (key0, data0, left0, node, size0)) | [] -> (* JYH: seems like we spend all our time checking check node (* n8 debugging *) *) node | Left Leaf :: _ | Right Leaf :: _ | Delete _ :: _ -> raise (Invalid_argument "restore") and delete_min path node = match node with Black (key0, data0, Leaf, Leaf, _) -> lift_black (key0, data0) path Leaf | Black (key0, data0, Leaf, Red (key2, data2, left2, right2, size2), _) -> lift (key0, data0) path (Black (key2, data2, left2, right2, size2)) | Red (key0, data0, Leaf, Leaf, _) -> lift (key0, data0) path Leaf | Black (_, _, left0, _, _) -> delete_min (Left node :: path) left0 | Red (_, _, left0, _, _) -> delete_min (Left node :: path) left0 | Leaf -> raise Not_found (* * Copy the tree with no need to propagate black. *) and lift key path node = match path, node with Left (Black (key0, data0, _, right0, size0)) :: path, left -> lift key path (Black (key0, data0, left, right0, pred size0)) | Left (Red (key0, data0, _, right0, size0)) :: path, left -> lift key path (Red (key0, data0, left, right0, pred size0)) | Right (Black (key0, data0, left0, _, size0)) :: path, right -> lift key path (Black (key0, data0, left0, right, pred size0)) | Right (Red (key0, data0, left0, _, size0)) :: path, right -> lift key path (Red (key0, data0, left0, right, pred size0)) | Delete (Black (_, _, left0, _, size0)) :: path, right -> let key0, data0 = key in lift key path (Black (key0, data0, left0, right, pred size0)) | Delete (Red (_, _, left0, _, size0)) :: path, right -> let key0, data0 = key in lift key path (Red (key0, data0, left0, right, pred size0)) | [], node -> node | Left Leaf :: _, _ | Right Leaf :: _, _ | Delete Leaf :: _, _ -> raise (Invalid_argument "lift") (* * Propagate the extra black up the tree. *) and lift_black key path node = match path, node with Left (Black (key0, data0, _, right0, size0)) :: path, left -> begin match right0 with Black (key2, data2, left2, right2, size2) -> begin match left2, right2 with _, Red (key3, data3, left3, right3, size3) -> (* * key0:b key2:b * / \ / \ * left:bb key2:b key0:b right2:b * / \ / \ * left2 right2:r left:b left2 *) lift key path (**) (Black (key2, data2, new_black key0 data0 left left2, Black (key3, data3, left3, right3, size3), pred size0)) | Red (key3, data3, left3, right3, _), _ -> (* * key0:b key3:b * / \ / \ * left:bb key2:b key0:b key2:b * / \ / \ / \ * key3:r right2:b left:b left3 right3 right2:b * / \ * left3 right3 *) lift key path (**) (Black (key3, data3, new_black key0 data0 left left3, new_black key2 data2 right3 right2, pred size0)) | _ -> (* * key0:b key0:bb * / \ / \ * left:bb key2:b left:b key2:r * / \ / \ * left2:b right2:b left2:b right2:b *) lift_black key path (**) (Black (key0, data0, left, Red (key2, data2, left2, right2, size2), pred size0)) end | Red (key2, data2, left2, right2, _) -> begin match left2 with Black (key3, data3, Red (key4, data4, left4, right4, _), d, _) -> (* * key0:b key2:b * / \ / \ * left:bb key2:r key4:r right2:b * / \ / \ * key3:b right2:b key0:b key3:b * / \ / \ / \ * key4:r d left:b left4 right4 d * / \ * left4 right4 *) lift key path (**) (Black (key2, data2, new_red key4 data4 (**) (new_black key0 data0 left left4) (new_black key3 data3 right4 d), right2, pred size0)) | Black (key3, data3, c, Red (key4, data4, left4, right4, size4), _) -> (* * key0:b key2:b * / \ / \ * left:bb key2:r key3:r right2 * / \ / \ * key3:b right2 key0:b key4:b * / \ / \ * c key4:r left:b c *) lift key path (**) (Black (key2, data2, new_red key3 data3 (**) (new_black key0 data0 left c) (Black (key4, data4, left4, right4, size4)), right2, pred size0)) | Black (key3, data3, c, d, _) -> (* * key0:b key2:b * / \ / \ * left:bb key2:r key0:b right2:b * / \ / \ * key3:b right2:b left:b key3:r * / \ / \ * c:b d:b c:b d:b *) lift key path (**) (Black (key2, data2, new_black key0 data0 left (new_red key3 data3 c d), right2, pred size0)) | Red _ | Leaf -> raise (Invalid_argument "lift_black1") end | Leaf -> raise (Invalid_argument "lift_black2") end | Right (Black (key0, data0, left0, _, size0)) :: path, right -> begin match left0 with Black (key1, data1, left1, right1, size1) -> begin match left1, right1 with Red (key3, data3, left3, right3, size3), _ -> (* * key0:b key1:b * / \ / \ * key1:b right:bb left1:b key0:b * / \ / \ * left1:r right1 right1 right:b *) lift key path (**) (Black (key1, data1, Black (key3, data3, left3, right3, size3), new_black key0 data0 right1 right, pred size0)) | _, Red (key3, data3, left3, right3, _) -> (* * key0:b key3:b * / \ / \ * key1:b right:bb key1:b key0:b * / \ / \ / \ * left1:b key3:r left1:b left3 right3 right * / \ * left3 right3 *) lift key path (**) (Black (key3, data3, new_black key1 data1 left1 left3, new_black key0 data0 right3 right, pred size0)) | _ -> (* * key0:b key0:bb * / \ / \ * key1:b right:bb key1:r right:bb * / \ / \ * left1:b right1:b left1:b right1:b *) lift_black key path (**) (Black (key0, data0, Red (key1, data1, left1, right1, size1), right, pred size0)) end | Red (key1, data1, left1, right1, _) -> begin match right1 with Black (key3, data3, d, Red (key4, data4, left4, right4, _), _) -> (* * key0:b key1:b * / \ / \ * key1:r right:bb left1:b key4:r * / \ / \ * left1:b key3:b key3:b key0:b * / \ / \ / \ * d key4:r d left4 right4 right:b * / \ * left4 right4 *) lift key path (**) (Black (key1, data1, left1, new_red key4 data4 (**) (new_black key3 data3 d left4) (new_black key0 data0 right4 right), pred size0)) | Black (key3, data3, Red (key4, data4, left4, right4, size4), c, _) -> (* * key0:b key1:b * / \ / \ * key1:r right:bb left1 key3:r * / \ / \ * left1 key3:b key4:b key0:b * / \ / \ * key4:r c c right:b *) lift key path (**) (Black (key1, data1, left1, new_red key3 data3 (**) (Black (key4, data4, left4, right4, size4)) (new_black key0 data0 c right), pred size0)) | Black (key3, data3, c, d, size3) -> (* * key0:b key1:b * / \ / \ * key1:r right:bb left1 key0:b * / \ / \ * left1 key3:b key3:r right:b * / \ / \ * c:b d:b c:b d:b *) lift key path (**) (Black (key1, data1, left1, new_black key0 data0 (Red (key3, data3, c, d, size3)) right, pred size0)) | Red _ | Leaf -> raise (Invalid_argument "lift_black3") end | Leaf -> raise (Invalid_argument "lift_black4") end | Left (Red (key0, data0, _, right0, size0)) :: path, left -> begin match right0 with Black (key2, data2, left2, right2, size2) -> begin match left2, right2 with _, Red (key3, data3, left3, right3, size3) -> (* * key0:r key2:r * / \ / \ * left:bb key2:b key0:b right2:b * / \ / \ * left2:b right2:r left:b left2:b *) lift key path (**) (Red (key2, data2, new_black key0 data0 left left2, Black (key3, data3, left3, right3, size3), pred size0)) | Red (key3, data3, left3, right3, _), _ -> (* * key0:r key3:b * / \ / \ * left:bb key2:b key0:r key2:r * / \ / \ / \ * key3:r right2 left:b left3 right3 right2 * / \ * left3 right3 *) lift key path (**) (Black (key3, data3, new_red key0 data0 left left3, new_red key2 data2 right3 right2, pred size0)) | _ -> (* * key0:r key0:b * / \ / \ * left:bb key2:b left:b key2:r * / \ / \ * left2:b right2:b left2:b right2:b *) lift key path (**) (Black (key0, data0, left, Red (key2, data2, left2, right2, size2), pred size0)) end | Red _ | Leaf -> raise (Invalid_argument "lift_black5") end | Right (Red (key0, data0, left0, _, size0)) :: path, right -> begin match left0 with Black (key1, data1, left1, right1, size1) -> begin match left1, right1 with Red (key3, data3, left3, right3, size3), _ -> (* * key0:r key1:r * / \ / \ * key1:b right:bb left1:b key0:b * / \ / \ * left1:r right1 right1 right:b *) lift key path (**) (Red (key1, data1, Black (key3, data3, left3, right3, size3), new_black key0 data0 right1 right, pred size0)) | _, Red (key3, data3, left3, right3, _) -> (* * key0:r key3:b * / \ / \ * key1:b right:bb key1:r key0:r * / \ / \ / \ * left1 key3:r left1 left3 right3 right:b * / \ * left3 right3 *) lift key path (**) (Black (key3, data3, new_red key1 data1 left1 left3, new_red key0 data0 right3 right, pred size0)) | _ -> (* * key0:r key0:b * / \ / \ * key1:b right:bb key1:r right:b * / \ / \ * left1:b right1:b left1:b right1:b *) lift key path (**) (Black (key0, data0, Red (key1, data1, left1, right1, size1), right, pred size0)) end | Red _ | Leaf -> raise (Invalid_argument "lift_black6") end | Delete (Black (_, _, left0, right0, size0)) :: path, node -> let key0, data0 = key in lift_black key (Right (Black (key0, data0, left0, right0, size0)) :: path) node | Delete (Red (_, _, left0, right0, size0)) :: path, node -> let key0, data0 = key in lift_black key (Right (Red (key0, data0, left0, right0, size0)) :: path) node | [], node -> node | Left Leaf :: _, _ | Right Leaf :: _, _ | Delete Leaf :: _, _ -> raise (Invalid_argument "lift_black7") (* * Remove the item. *) let remove tree key = try delete key (fun _ -> None) [] tree with Not_found -> tree let filter_remove tree key filter = delete key filter [] tree (************************************************************************ * UNION & INTERSECTION * ************************************************************************) (* * Get the smallest element. *) let rec choose = function Black (key, data, Leaf, _, _) | Red (key, data, Leaf, _, _) -> key, data | Black (_, _, left, _, _) | Red (_, _, left, _, _) -> choose left | Leaf -> raise Not_found (* * Get the elements of the list. *) let rec to_list_aux elements = function Black (key, data, left, right, _) | Red (key, data, left, right, _) -> to_list_aux ((key, data) :: to_list_aux elements right) left | Leaf -> elements let to_list tree = to_list_aux [] tree (* let elements = to_list *) (* let rec keys_aux elements = function *) (* Black (key, _, left, right, _) *) (* | Red (key, _, left, right, _) -> *) (* keys_aux (key :: keys_aux elements right) left *) (* | Leaf -> *) (* elements *) (* let keys = keys_aux [] *) (* let rec reverse elements = function *) (* h :: t -> *) (* reverse (h :: elements) t *) (* | [] -> *) (* elements *) (* let rec merge elements elements1 elements2 = *) (* match elements1, elements2 with *) (* ((key1, data1) as hd1) :: tl1, ((key2, data2) as hd2) :: tl2 -> *) (* let comp = Base.compare key1 key2 in *) (* if comp = 0 then *) (* merge ((key1, data1 @ data2) :: elements) tl1 tl2 *) (* else if comp < 0 then *) (* merge (hd1 :: elements) tl1 elements2 *) (* else *) (* merge (hd2 :: elements) elements1 tl2 *) (* | _, [] -> *) (* reverse elements1 elements *) (* | [], _ -> *) (* reverse elements2 elements *) (* * Log of a number. *) (* let rec log2 i x = *) (* if 1 lsl i >= x then *) (* i *) (* else *) (* log2 (succ i) x *) (* * Build a set from a list. *) (* let rec log2 i j = *) (* if 1 lsl i >= j then *) (* i *) (* else *) (* log2 (succ i) j *) (* let rec of_array depth max_depth elements off len = *) (* if len = 1 then *) (* let key, data = elements.(off) in *) (* if depth = max_depth then *) (* Red (key, data, Leaf, Leaf, 1) *) (* else *) (* Black (key, data, Leaf, Leaf, 1) *) (* else if len = 2 then *) (* let key1, data1 = elements.(off) in *) (* let key0, data0 = elements.(succ off) in *) (* Black (key0, data0, Red (key1, data1, Leaf, Leaf, 1), Leaf, 2) *) (* else *) (* let len2 = len lsr 1 in *) (* let key0, data0 = elements.(off + len2) in *) (* Black (key0, data0, *) (* of_array (succ depth) max_depth elements off len2, *) (* of_array (succ depth) max_depth elements (off + len2 + 1) (len - len2 - 1), *) (* len) *) (* let of_list elements = *) (* match elements with *) (* [] -> *) (* Leaf *) (* | [key, data] -> *) (* Black (key, data, Leaf, Leaf, 1) *) (* | elements -> *) (* let elements = Array.of_list elements in *) (* let length = Array.length elements in *) (* let max_depth = pred (log2 1 (succ length)) in *) (* of_array 0 max_depth elements 0 length *) (* * Union flattens the two trees, * merges them, then creates a new tree. *) let union_append (append : 'elt -> 'data -> 'data -> 'data) (s : ('elt, 'data) tree) (key : 'elt) (data : 'data) = filter_add s key (function None -> data | Some data' -> append key data' data) let rec union_aux (append : 'elt -> 'data -> 'data -> 'data) (s1 : ('elt, 'data) tree) (s2 : ('elt, 'data) tree) = match s2 with Black (key, data, left, right, _) | Red (key, data, left, right, _) -> union_aux append (union_append append (union_aux append s1 left) key data) right | Leaf -> s1 let union append s1 s2 = let size1 = cardinality s1 in let size2 = cardinality s2 in if size1 < size2 then union_aux append s2 s1 else union_aux append s1 s2 (* * See if two sets intersect. *) (* let rec intersect_aux elems1 elems2 = *) (* match elems1, elems2 with *) (* elem1 :: elems1', elem2 :: elems2' -> *) (* let comp = Base.compare elem1 elem2 in *) (* if comp = 0 then *) (* true *) (* else if comp < 0 then *) (* intersect_aux elems1' elems2 *) (* else *) (* intersect_aux elems1 elems2' *) (* | [], _ *) (* | _, [] -> *) (* false *) (* let intersectp s1 s2 = *) (* intersect_aux (keys s1) (keys s2) *) (* * Equality of sets. *) let equal eq set1 set2 = if cardinality set1 = cardinality set2 then let list1 = to_list set1 in let list2 = to_list set2 in List.for_all2 (fun (x1, x2) (y1, y2) -> Base.compare x1 y1 = 0 && eq x2 y2) list1 list2 else false (************************************************************************ * IMPLEMENTATION * ************************************************************************) (* * Search without reorganizing the tree. *) let rec mem tree key = match tree with Black (key', _, left, right, _) | Red (key', _, left, right, _) -> let comp = Base.compare key key' in if comp = 0 then true else if comp < 0 then mem left key else mem right key | Leaf -> false let rec find_key tree key = match tree with Black (key', _, left, right, _) | Red (key', _, left, right, _) -> let comp = Base.compare key key' in if comp = 0 then Some key' else if comp < 0 then find_key left key else find_key right key | Leaf -> None (* * An empty tree is just a leaf. *) let empty = Leaf let is_empty = function Leaf -> true | Red _ | Black _ -> false (* let make key data = *) (* Black (key, data, Leaf, Leaf, 1) *) (* * Iterate a function over the hashtable. *) let rec iter f = function Black (key, data, left, right, _) | Red (key, data, left, right, _) -> iter f left; f key data; iter f right | Leaf -> () (* let iter_all = iter *) let rec map f = function Black (key, data, left, right, size) -> let left = map f left in let data = f data in let right = map f right in Black (key, data, left, right, size) | Red (key, data, left, right, size) -> let left = map f left in let data = f data in let right = map f right in Red (key, data, left, right, size) | Leaf -> Leaf let rec mapi f = function Black (key, data, left, right, size) -> let left = mapi f left in let data = f key data in let right = mapi f right in Black (key, data, left, right, size) | Red (key, data, left, right, size) -> let left = mapi f left in let data = f key data in let right = mapi f right in Red (key, data, left, right, size) | Leaf -> Leaf (* let rec mapi_all f = function *) (* Black (key, data, left, right, size) -> *) (* let left = mapi_all f left in *) (* let data = f key data in *) (* let right = mapi_all f right in *) (* Black (key, data, left, right, size) *) (* | Red (key, data, left, right, size) -> *) (* let left = mapi_all f left in *) (* let data = f key data in *) (* let right = mapi_all f right in *) (* Red (key, data, left, right, size) *) (* | Leaf -> *) (* Leaf *) let rec fold f arg = function Black (key, data, left, right, _) | Red (key, data, left, right, _) -> let arg = fold f arg left in let arg = f arg key data in fold f arg right | Leaf -> arg (* let fold_all = fold *) let rec fold_map f arg = function Black (key, data, left, right, size) -> let arg, left = fold_map f arg left in let arg, data = f arg key data in let arg, right = fold_map f arg right in arg, Black (key, data, left, right, size) | Red (key, data, left, right, size) -> let arg, left = fold_map f arg left in let arg, data = f arg key data in let arg, right = fold_map f arg right in arg, Red (key, data, left, right, size) | Leaf -> arg, Leaf let forall2 cmp t1 t2 = (cardinal t1 = cardinal t2) && List.for_all2 (fun (x1, e1) (x2, e2) -> Base.compare x1 x2 = 0 && cmp e1 e2) (to_list t1) (to_list t2) let rec forall cmp t = match t with Black (key, data, left, right, _) | Red (key, data, left, right, _) -> cmp key data && forall cmp left && forall cmp right | Leaf -> true let rec exists cmp t = match t with Black (key, data, left, right, _) | Red (key, data, left, right, _) -> cmp key data || exists cmp left || exists cmp right | Leaf -> false let rec find_iter cmp t = match t with Black (key, data, left, right, _) | Red (key, data, left, right, _) -> let x = cmp key data in (match x with Some _ -> x | None -> let x = find_iter cmp left in match x with Some _ -> x | None -> find_iter cmp right) | Leaf -> None let isect_mem t test = fold (fun t' v x -> if test v then add t' v x else t') empty t let rec keys_acc t acc = match t with Black (key,_,left,right,_) | Red (key,_,left,right,_) -> keys_acc left (key::keys_acc right acc) | Leaf -> acc let keys t = keys_acc t [] let rec data_acc t acc = match t with Black (_,data,left,right,_) | Red (_,data,left,right,_) -> data_acc left (data::data_acc right acc) | Leaf -> acc let data t = data_acc t [] let rec add_list map = function [] -> map | (key,data)::tl -> add_list (add map key data) tl end (* * Recursive version. *) module LmMakeRec = LmMake (* * List version. *) module LmMakeList (Ord : OrderedType) = struct module MMap = LmMake (Ord) type key = Ord.t type 'a t = 'a list MMap.t let empty = MMap.empty let is_empty = MMap.is_empty let cardinal = MMap.cardinal let filter_add t key f = MMap.filter_add t key (function Some (h :: t) -> f (Some h) :: t | Some [] | None -> [f None]) let filter_remove t key f = MMap.filter_remove t key (function h :: t -> (match f h with None -> None | Some h -> Some (h :: t)) | [] -> None) let replace t key f = MMap.filter_add t key (function Some (h :: t) -> f h :: t | Some [] | None -> raise Not_found) let add t key x = MMap.filter_add t key (function Some l -> x :: l | None -> [x]) let find t key = match MMap.find t key with [] -> raise Not_found | h :: _ -> h let remove = MMap.remove let mem = MMap.mem let find_key = MMap.find_key let iter f t = MMap.iter (fun i l -> match l with [] -> () | h :: _ -> f i h) t let map f t = MMap.map (function [] -> [] | h :: _ -> [f h]) t let mapi f t = MMap.mapi (fun i l -> match l with [] -> [] | h :: _ -> [f i h]) t let fold f = MMap.fold (fun x key -> function [] -> x | h :: _ -> f x key h) let fold_map f x t = MMap.fold_map (fun x key data -> List.fold_left (fun (x, data) d -> let x, d = f x key d in let data = d :: data in x, data) (x, []) data) x t let iter_all = MMap.iter let mapi_all = MMap.mapi let fold_all = MMap.fold let data_all = MMap.data let rec add_list map = function [] -> map | (key,data)::tl -> add_list (add map key data) tl let choose t = let key, data = MMap.choose t in match data with [] -> raise Not_found | h :: _ -> key, h let choose_all = MMap.choose (* * find_all is a total function. * find_all_partial fails if the element is not in the table. *) let find_all_partial = MMap.find let find_all = MMap.find_all let filter t key f = (* table_ext v_ext search *) try MMap.filter_remove t key (fun l -> match f l with [] -> None | l -> Some l) with Not_found -> match f [] with [] -> t | l -> MMap.add t key l let forall2 cmp t1 t2 = let cmp l1 l2 = let len1 = List.length l1 in let len2 = List.length l2 in len1 = len2 && List.for_all2 cmp l1 l2 in MMap.forall2 cmp t1 t2 let forall cmp t = let cmp_list key l = List.for_all (fun x -> cmp key x) l in MMap.forall cmp_list t let exists cmp t = let cmp_list key l = List.exists (fun x -> cmp key x) l in MMap.exists cmp_list t let find_iter cmp t = let rec cmp_list key l = match l with h :: t -> let x = cmp key h in (match x with Some _ -> x | None -> cmp_list key t) | [] -> None in MMap.find_iter cmp_list t let isect_mem t test = MMap.isect_mem t test let keys t = MMap.keys t let data t = List.concat (MMap.data t) let union = MMap.union let equal eq set1 set2 = if MMap.cardinality set1 = MMap.cardinality set2 then let list1 = MMap.to_list set1 in let list2 = MMap.to_list set2 in List.for_all2 (fun (_x1, x2) (_y1, y2) -> List.length x2 = List.length y2 && List.for_all2 eq x2 y2) list1 list2 else false end (* * Backwards-compatible version. *) module Make (Ord : OrderedType) = struct module XMap = LmMake (Ord) type 'a t = 'a XMap.t type key = XMap.key let empty = XMap.empty let add key data tbl = XMap.add tbl key data let find key tbl = XMap.find tbl key let remove key tbl = XMap.remove tbl key let mem key tbl = XMap.mem tbl key let iter = XMap.iter let map = XMap.map let mapi = XMap.mapi let fold f tbl x = XMap.fold (fun x key data -> f key data x) x tbl end omake-0.10.3/src/libmojave/lm_set.ml0000644000175000017500000013171713177364665015723 0ustar gerdgerd(* * Build a set using a red-black tree. * Every node in the tree is colored either black or red. * A red-black tree has the following invariants: * 1. Every leaf is colored black * 2. All children of every red node are black. * 3. Every path from the root to a leaf has the * same number of black nodes as every other path. * 4. The root is always black. * * We get some corollaries: * 1. The longest path from the root to a leaf is * at most twice as long as the shortest path. * 2. Both children of a red node are either leaves, * or they are both not. * * This code is meant to be fast, so all the cases have * been expanded, and the insert and delete functions are * long (12 cases for insert, 18 for delete in lift_black). * *) module LmMake (Ord : Lm_set_sig.OrderedType) = struct (************************************************************************ * TYPES * ************************************************************************) type elt = Ord.t (* * Table is a binary tree. * Color is kept in the label to save space. *) (* %%MAGICBEGIN%% *) type tree = | Leaf | Red of elt * tree * tree * int | Black of elt * tree * tree * int (* %%MAGICEND%% *) (* * The tree is always balanced, so we don't need * extra mutable fields. *) type t = tree (* * Path into the tree. *) type path = | Left of tree | Right of tree | Delete of tree (* * Exception for unchanged tree during insertion. *) exception Unchanged (************************************************************************ * IMPLEMENTATION * ************************************************************************) (* * Size of a table. *) let cardinality = function | Red (_, _, _, size) | Black (_, _, _, size) -> size | Leaf -> 0 (* * Add two nodes. *) let new_black key left right = Black (key, left, right, cardinality left + cardinality right + 1) let new_red key left right = Red (key, left, right, cardinality left + cardinality right + 1) (* * Print the tree. *) (* let rec pp_print_tree out tree = *) (* match tree with *) (* | Black (_, left, right, size) -> *) (* Lm_printf.fprintf out "@[Black(%d):@ %a@ %a@]" size pp_print_tree left pp_print_tree right *) (* | Red (_, left, right, size) -> *) (* Lm_printf.fprintf out "@[Red(%d):@ %a@ %a@]" size pp_print_tree left pp_print_tree right *) (* | Leaf -> *) (* Lm_printf.fprintf out "Leaf" *) (* let print_tree = pp_print_tree Lm_printf.stdout *) (* * Check the size of the set. *) (* let check_size tree = *) (* let abort tree' = *) (* Lm_printf.printf "%a@\n%a@\n" pp_print_tree tree pp_print_tree tree'; *) (* raise (Invalid_argument "check_size") *) (* in *) (* let rec check tree = *) (* match tree with *) (* | Black (_, left, right, size) -> *) (* if size <> check left + check right + 1 then *) (* abort tree; *) (* size *) (* | Red (_, left, right, size) -> *) (* if size <> check left + check right + 1 then *) (* abort tree; *) (* size *) (* | Leaf -> 0 in *) (* check tree *) (* * Check the red-invariant. *) (* let rec check_red = function *) (* | Red (_, Red _, _, _) *) (* | Red (_, _, Red _, _) -> *) (* raise (Failure "Lm_set.check_red") *) (* | Red (_, left, right, _) *) (* | Black (_, left, right, _) -> *) (* check_red left; *) (* check_red right *) (* | Leaf -> () *) (* * Check the black invariant. *) (* let rec black_depth i = function *) (* Black (_, left, _, _) -> *) (* black_depth (succ i) left *) (* | Red (_, left, _, _) -> *) (* black_depth i left *) (* | Leaf -> i *) (* let rec check_black_aux i j = function *) (* | Black (_, left, right, _) -> *) (* check_black_aux i ( i + 1 ) left; *) (* check_black_aux i ( j + 1 ) right *) (* | Red (_, left, right, _) -> *) (* check_black_aux i j left; *) (* check_black_aux i j right *) (* | Leaf -> *) (* if j <> i then *) (* raise (Failure "Lm_set.check_black") *) (* let check_black tree = *) (* check_black_aux (black_depth 0 tree) 0 tree *) (* * Check that all the nodes are sorted. *) (* let rec check_sort_lt key = function *) (* Black (key', left, right, _) *) (* | Red (key', left, right, _) -> *) (* if Ord.compare key' key >= 0 then *) (* raise (Failure "Lm_set.check_sort"); *) (* check_sort_lt key' left; *) (* check_sort_gt_lt key' key right *) (* | Leaf -> *) (* () *) (* and check_sort_gt key = function *) (* Black (key', left, right, _) *) (* | Red (key', left, right, _) -> *) (* if Ord.compare key' key <= 0 then *) (* raise (Failure "Lm_set.check_sort"); *) (* check_sort_gt_lt key key' left; *) (* check_sort_gt key right *) (* | Leaf -> *) (* () *) (* and check_sort_gt_lt key key' = function *) (* Black (key'', left, right, _) *) (* | Red (key'', left, right, _) -> *) (* if Ord.compare key'' key <= 0 || Ord.compare key'' key' >= 0 then *) (* raise (Failure "Lm_set.check_sort"); *) (* check_sort_gt_lt key key'' left; *) (* check_sort_gt_lt key'' key' right *) (* | Leaf -> *) (* () *) (* let check_sort = function *) (* Black (key, left, right, _) -> *) (* check_sort_lt key left; *) (* check_sort_gt key right *) (* | Red _ -> *) (* raise (Failure "Lm_set.check_sort: root is red") *) (* | Leaf -> *) (* () *) (************************************************************************ * INSERTION * ************************************************************************) (* * Insert an entry into the tree. *) let rec insert key = function | Black (key0, left0, right0, size0) -> begin let comp = Ord.compare key key0 in if comp = 0 then raise Unchanged else if comp < 0 then match left0 with | Black _ | Leaf -> (* * Ok even if child becomes red. *) Black (key0, insert key left0, right0, succ size0) | Red (key1, left1, right1, size1) -> let comp = Ord.compare key key1 in if comp = 0 then raise Unchanged else if comp < 0 then match insert key left1, right0 with | Red _ as node, Red (key2, left2, right2, size2) -> (* * Recoloring: * * key0:b key0:r * / \ / \ * key1:r key2:r key1:b key2:b * / \ / \ * key2:r right1 key2:r right1 *) Red (key0, Black (key1, node, right1, succ size1), Black (key2, left2, right2, size2), succ size0) | Red _ as node, _ -> (* * Rotation: * * key0:b key1:b * / \ / \ * key1:r key2:b key3:r key0:b * / \ / \ * key3:r right1 right1 key2:r *) Black (key1, node, new_red key0 right1 right0, succ size0) | node, _ -> (* * Inline: * * key0:b key0:b * / \ / \ * key1:r key2 key1:r key2 * / \ / \ * key3:b right1 key3:b right1 *) Black (key0, new_red key1 node right1, right0, succ size0) else match insert key right1, right0 with | Red _ as node, Red (key2, left2, right2, size2) -> (* * Recoloring: * * key0:b key0:r * / \ / \ * key1:r key2:r key1:b key2:b * / \ / \ * left1 node:r left1 node:r *) Red (key0, Black (key1, left1, node, succ size1), Black (key2, left2, right2, size2), succ size0) | Red (key3, left3, right3, _), _ -> (* * Rotation: * * key0:b key3:b * / \ / \ * key1:r right0 key1:r key0:r * / \ / \ / \ * left1 key3:r left1 left3 right3 right0 * / \ * left3 right3 *) Black (key3, new_red key1 left1 left3, new_red key0 right3 right0, succ size0) | node3, _ -> (* * Inline: * * key0:b * / \ * key1:r right0 * / \ * left1 node3:b *) Black (key0, new_red key1 left1 node3, right0, succ size0) else (* comp > 0 *) match right0 with | Black _ | Leaf -> (* * Node can be replaced even if it becomes red. *) Black (key0, left0, insert key right0, succ size0) | Red (key2, left2, right2, size2) -> let comp = Ord.compare key key2 in if comp = 0 then raise Unchanged else if comp < 0 then match left0, insert key left2 with Red (key1, left1, right1, size1), (Red _ as node) -> (* * Recoloring: * * key0:b key0:r * / \ / \ * key1:r key2:r key1:b key2:b * / \ / \ * node:r right2 node:r right2 *) Red (key0, Black (key1, left1, right1, size1), Black (key2, node, right2, succ size2), succ size0) | _, Red (key3, left3, right3, _) -> (* * Rotate: * * key0:b key3:b * / \ / \ * key1:b key2:r key0:r key2:r * / \ / \ / \ * key3:r right2 left0 left3 right3 right2 * / \ * left3 right3 *) Black (key3, new_red key0 left0 left3, new_red key2 right3 right2, succ size0) | _, node3 -> (* * Inline: * * key0:b * / \ * left0 key2:r * / \ * key3:b right2 *) Black (key0, left0, new_red key2 node3 right2, succ size0) else match left0, insert key right2 with Red (key1, left1, right1, size1), (Red _ as node) -> (* * Recoloring: * * key0:b key0:r * / \ / \ * key1:r key2:r key1:b key2:b * / \ / \ * left2 node:r left2 node:r *) Red (key0, Black (key1, left1, right1, size1), Black (key2, left2, node, succ size2), succ size0) | _, (Red _ as node) -> (* * Rotation: * * key0:b key2:b * / \ / \ * left0:b key2:r key0:r node:r * / \ / \ * left2 node:r left0:b left2 *) Black (key2, new_red key0 left0 left2, node, succ size0) | _, node3 -> (* * Inline: * * key0:b * / \ * left0:b key2:r * / \ * left2 node3:b *) Black (key0, left0, new_red key2 left2 node3, succ size0) end | Leaf -> (* Leaf is colored red *) Red (key, Leaf, Leaf, 1) | (Red _) -> (* Red nodes will not come up *) raise (Invalid_argument "Lm_set.insert") (* * Add an element to the set. *) let add t key = match t with | Leaf -> Black (key, Leaf, Leaf, 1) | node -> try match insert key node with | Red (key, left, right, size) -> Black (key, left, right, size) | tree -> tree with Unchanged -> node let add_list set keys = List.fold_left add set keys (************************************************************************ * REMOVAL * ************************************************************************) (* * Construct a path during the removal. *) let rec delete key path node = match node with Black (key', left, right, _) -> let comp = Ord.compare key key' in if comp = 0 then match left, right with Leaf, Leaf -> lift_black key path Leaf | Red (key, left, right, size), Leaf -> lift key path (Black (key, left, right, size)) | _ -> delete_min (Delete node :: path) right else if comp < 0 then delete key (Left node :: path) left else delete key (Right node :: path) right | Red (key', left, right, _) -> let comp = Ord.compare key key' in if comp = 0 then match right with Leaf -> lift key path Leaf | _ -> delete_min (Delete node :: path) right else if comp < 0 then delete key (Left node :: path) left else delete key (Right node :: path) right | Leaf -> raise Not_found and delete_min path node = match node with Black (key, Leaf, Leaf, _) -> lift_black key path Leaf | Black (key, Leaf, Red (key', left, right, size), _) -> lift key path (Black (key', left, right, size)) | Red (key, Leaf, Leaf, _) -> lift key path Leaf | Black (_, left, _, _) -> delete_min (Left node :: path) left | Red (_, left, _, _) -> delete_min (Left node :: path) left | Leaf -> raise Not_found (* * Copy the tree with no need to propagate black. *) and lift key path node = match path, node with Left (Black (key0, _, right0, size0)) :: path, left -> lift key path (Black (key0, left, right0, pred size0)) | Left (Red (key0, _, right0, size0)) :: path, left -> lift key path (Red (key0, left, right0, pred size0)) | Right (Black (key0, left0, _, size0)) :: path, right -> lift key path (Black (key0, left0, right, pred size0)) | Right (Red (key0, left0, _, size0)) :: path, right -> lift key path (Red (key0, left0, right, pred size0)) | Delete (Black (_, left0, _, size0)) :: path, right -> lift key path (Black (key, left0, right, pred size0)) | Delete (Red (_, left0, _, size0)) :: path, right -> lift key path (Red (key, left0, right, pred size0)) | [], node -> node | Left Leaf :: _, _ | Right Leaf :: _, _ | Delete Leaf :: _, _ -> raise (Invalid_argument "lift") (* * Propagate the extra black up the tree. *) and lift_black key path node = match path, node with Left (Black (key0, _, right0, size0)) :: path, left -> begin match right0 with Black (key2, left2, right2, size2) -> begin match left2, right2 with _, Red (key3, left3, right3, size3) -> (* * key0:b key2:b * / \ / \ * left:bb key2:b key0:b right2:b * / \ / \ * left2 right2:r left:b left2 *) lift key path (**) (Black (key2, new_black key0 left left2, Black (key3, left3, right3, size3), pred size0)) | Red (key3, left3, right3, _), _ -> (* * key0:b key3:b * / \ / \ * left:bb key2:b key0:b key2:b * / \ / \ / \ * key3:r right2:b left:b left3 right3 right2:b * / \ * left3 right3 *) lift key path (**) (Black (key3, new_black key0 left left3, new_black key2 right3 right2, pred size0)) | _ -> (* * key0:b key0:bb * / \ / \ * left:bb key2:b left:b key2:r * / \ / \ * left2:b right2:b left2:b right2:b *) lift_black key path (**) (Black (key0, left, Red (key2, left2, right2, size2), pred size0)) end | Red (key2, left2, right2, _) -> begin match left2 with Black (key3, Red (key4, left4, right4, _), d, _) -> (* * key0:b key2:b * / \ / \ * left:bb key2:r key4:r right2:b * / \ / \ * key3:b right2:b key0:b key3:b * / \ / \ / \ * key4:r d left:b left4 right4 d * / \ * left4 right4 *) lift key path (**) (Black (key2, new_red key4 (**) (new_black key0 left left4) (new_black key3 right4 d), right2, pred size0)) | Black (key3, c, Red (key4, left4, right4, size4), _) -> (* * key0:b key2:b * / \ / \ * left:bb key2:r key3:r right2 * / \ / \ * key3:b right2 key0:b key4:b * / \ / \ * c key4:r left:b c *) lift key path (**) (Black (key2, new_red key3 (**) (new_black key0 left c) (Black (key4, left4, right4, size4)), right2, pred size0)) | Black (key3, c, d, _) -> (* * key0:b key2:b * / \ / \ * left:bb key2:r key0:b right2:b * / \ / \ * key3:b right2:b left:b key3:r * / \ / \ * c:b d:b c:b d:b *) lift key path (**) (Black (key2, new_black key0 left (new_red key3 c d), right2, pred size0)) | Red _ | Leaf -> raise (Invalid_argument "lift_black1") end | Leaf -> raise (Invalid_argument "lift_black2") end | Right (Black (key0, left0, _, size0)) :: path, right -> begin match left0 with Black (key1, left1, right1, size1) -> begin match left1, right1 with Red (key3, left3, right3, size3), _ -> (* * key0:b key1:b * / \ / \ * key1:b right:bb left1:b key0:b * / \ / \ * left1:r right1 right1 right:b *) lift key path (**) (Black (key1, Black (key3, left3, right3, size3), new_black key0 right1 right, pred size0)) | _, Red (key3, left3, right3, _) -> (* * key0:b key3:b * / \ / \ * key1:b right:bb key1:b key0:b * / \ / \ / \ * left1:b key3:r left1:b left3 right3 right * / \ * left3 right3 *) lift key path (**) (Black (key3, new_black key1 left1 left3, new_black key0 right3 right, pred size0)) | _ -> (* * key0:b key0:bb * / \ / \ * key1:b right:bb key1:r right:bb * / \ / \ * left1:b right1:b left1:b right1:b *) lift_black key path (**) (Black (key0, Red (key1, left1, right1, size1), right, pred size0)) end | Red (key1, left1, right1, _) -> begin match right1 with Black (key3, d, Red (key4, left4, right4, _), _) -> (* * key0:b key1:b * / \ / \ * key1:r right:bb left1:b key4:r * / \ / \ * left1:b key3:b key3:b key0:b * / \ / \ / \ * d key4:r d left4 right4 right:b * / \ * left4 right4 *) lift key path (**) (Black (key1, left1, new_red key4 (**) (new_black key3 d left4) (new_black key0 right4 right), pred size0)) | Black (key3, Red (key4, left4, right4, size4), c, _) -> (* * key0:b key1:b * / \ / \ * key1:r right:bb left1 key3:r * / \ / \ * left1 key3:b key4:b key0:b * / \ / \ * key4:r c c right:b *) lift key path (**) (Black (key1, left1, new_red key3 (**) (Black (key4, left4, right4, size4)) (new_black key0 c right), pred size0)) | Black (key3, c, d, size3) -> (* * key0:b key1:b * / \ / \ * key1:r right:bb left1 key0:b * / \ / \ * left1 key3:b key3:r right:b * / \ / \ * c:b d:b c:b d:b *) lift key path (**) (Black (key1, left1, new_black key0 (Red (key3, c, d, size3)) right, pred size0)) | Red _ | Leaf -> raise (Invalid_argument "lift_black3") end | Leaf -> raise (Invalid_argument "lift_black4") end | Left (Red (key0, _, right0, size0)) :: path, left -> begin match right0 with Black (key2, left2, right2, size2) -> begin match left2, right2 with _, Red (key3, left3, right3, size3) -> (* * key0:r key2:r * / \ / \ * left:bb key2:b key0:b right2:b * / \ / \ * left2:b right2:r left:b left2:b *) lift key path (**) (Red (key2, new_black key0 left left2, Black (key3, left3, right3, size3), pred size0)) | Red (key3, left3, right3, _), _ -> (* * key0:r key3:b * / \ / \ * left:bb key2:b key0:r key2:r * / \ / \ / \ * key3:r right2 left:b left3 right3 right2 * / \ * left3 right3 *) lift key path (**) (Black (key3, new_red key0 left left3, new_red key2 right3 right2, pred size0)) | _ -> (* * key0:r key0:b * / \ / \ * left:bb key2:b left:b key2:r * / \ / \ * left2:b right2:b left2:b right2:b *) lift key path (**) (Black (key0, left, Red (key2, left2, right2, size2), pred size0)) end | Red _ | Leaf -> raise (Invalid_argument "lift_black5") end | Right (Red (key0, left0, _, size0)) :: path, right -> begin match left0 with Black (key1, left1, right1, size1) -> begin match left1, right1 with Red (key3, left3, right3, size3), _ -> (* * key0:r key1:r * / \ / \ * key1:b right:bb left1:b key0:b * / \ / \ * left1:r right1 right1 right:b *) lift key path (**) (Red (key1, Black (key3, left3, right3, size3), new_black key0 right1 right, pred size0)) | _, Red (key3, left3, right3, _) -> (* * key0:r key3:b * / \ / \ * key1:b right:bb key1:r key0:r * / \ / \ / \ * left1 key3:r left1 left3 right3 right:b * / \ * left3 right3 *) lift key path (**) (Black (key3, new_red key1 left1 left3, new_red key0 right3 right, pred size0)) | _ -> (* * key0:r key0:b * / \ / \ * key1:b right:bb key1:r right:b * / \ / \ * left1:b right1:b left1:b right1:b *) lift key path (**) (Black (key0, Red (key1, left1, right1, size1), right, pred size0)) end | Red _ | Leaf -> raise (Invalid_argument "lift_black6") end | Delete (Black (_, left0, right0, size0)) :: path, node -> lift_black key (Right (Black (key, left0, right0, size0)) :: path) node | Delete (Red (_, left0, right0, size0)) :: path, node -> lift_black key (Right (Red (key, left0, right0, size0)) :: path) node | [], node -> node | Left Leaf :: _, _ | Right Leaf :: _, _ | Delete Leaf :: _, _ -> raise (Invalid_argument "lift_black7") (* * Remove the item. *) let remove tree key = try delete key [] tree with Not_found -> tree (* let subtract_list tree keys = *) (* List.fold_left remove tree keys *) (************************************************************************ * UNION & INTERSECTION * ************************************************************************) (* * Get the elements of the list. *) let rec to_list_aux elements = function Black (key, left, right, _) | Red (key, left, right, _) -> to_list_aux (key :: to_list_aux elements right) left | Leaf -> elements let to_list = to_list_aux [] let elements = to_list (* let rec reverse elements = function *) (* h :: t -> *) (* reverse (h :: elements) t *) (* | [] -> *) (* elements *) (* let rec merge elements elements1 elements2 = *) (* match elements1, elements2 with *) (* key1 :: tl1, key2 :: tl2 -> *) (* let comp = Ord.compare key1 key2 in *) (* if comp = 0 then *) (* merge (key1 :: elements) tl1 tl2 *) (* else if comp < 0 then *) (* merge (key1 :: elements) tl1 elements2 *) (* else *) (* merge (key2 :: elements) elements1 tl2 *) (* | _, [] -> *) (* reverse elements1 elements *) (* | [], _ -> *) (* reverse elements2 elements *) (* * Log of a number. *) (* let rec log2 i x = *) (* if 1 lsl i >= x then *) (* i *) (* else *) (* log2 (succ i) x *) (* * Build a set from a list. *) (* let rec log2 i j = *) (* if 1 lsl i >= j then *) (* i *) (* else *) (* log2 (succ i) j *) (* let rec of_sorted_array depth max_depth elements off len = *) (* if len = 1 then *) (* if depth = max_depth then *) (* Red (elements.(off), Leaf, Leaf, 1) *) (* else *) (* Black (elements.(off), Leaf, Leaf, 1) *) (* else if len = 2 then *) (* Black (elements.(off + 1), Red (elements.(off), Leaf, Leaf, 1), Leaf, 2) *) (* else *) (* let len2 = len lsr 1 in *) (* Black (elements.(off + len2), *) (* of_sorted_array (succ depth) max_depth elements off len2, *) (* of_sorted_array (succ depth) max_depth elements (off + len2 + 1) (len - len2 - 1), *) (* len) *) (* let of_sorted_list = function *) (* | [] -> Leaf *) (* | [key] -> *) (* Black (key, Leaf, Leaf, 1) *) (* | elements -> *) (* let elements = Array.of_list elements in *) (* let length = Lm_array_util.distinct compare elements in *) (* let max_depth = pred (log2 1 (succ length)) in *) (* of_sorted_array 0 max_depth elements 0 length *) (* * Convert to a list. *) let rec to_list_aux l = function | Black (key, left, right, _) | Red (key, left, right, _) -> to_list_aux (key :: to_list_aux l right) left | Leaf -> l let to_list t = to_list_aux [] t (* * Union flattens the two trees, * merges them, then creates a new tree. *) let rec union_aux s1 = function Black (key, left, right, _) | Red (key, left, right, _) -> union_aux (add (union_aux s1 left) key) right | Leaf -> s1 let union s1 s2 = let size1 = cardinality s1 in let size2 = cardinality s2 in if size1 < size2 then union_aux s2 s1 else union_aux s1 s2 (* * See if two sets intersect. *) (************************************************************************ * IMPLEMENTATION * ************************************************************************) (* * Search without reorganizing the tree. *) let rec mem t key = match t with | Black (key', left, right, _) | Red (key', left, right, _) -> let comp = Ord.compare key key' in if comp = 0 then true else if comp < 0 then mem left key else mem right key | Leaf -> false (** added new elements to match standard library *) let rec find key set = match set with | Leaf -> raise Not_found | Black(key', left, right, _ ) | Red(key', left,right, _) -> let comp = Ord.compare key key' in if comp = 0 then key' else if comp < 0 then find key left else find key right ;; (* let rec split key = function *) (* | Leaf -> (Leaf, false, Leaf) *) (* | Black(key', left, right, _) *) (* | Red(key',left,right) -> *) (* let comp = Ord.compare key key' in *) (* if comp = 0 then (left, true, right) *) (* else if comp < 0 then *) (* let (ll, pres, rl) = split key left in *) (* (ll, ) *) (* else *) (* * An empty tree is just a leaf. *) let empty = Leaf let is_empty = function Leaf -> true | _ -> false let singleton key = Black (key, Leaf, Leaf, 1) let of_list l = List.fold_left (fun set item -> add set item) empty l (* * Iterate a function over the hashtable. *) let rec iter f = function Black (key, left, right, _) | Red (key, left, right, _) -> iter f left; f key; iter f right | Leaf -> () (* * Fold a function over the subrange of the set *) (* let rec range_fold range f arg = function *) (* Black (key, left, right, _) *) (* | Red (key, left, right, _) -> *) (* let c = range key in *) (* if c > 0 then *) (* range_fold range f arg right *) (* else if c < 0 then *) (* range_fold range f arg left *) (* else *) (* let arg = range_fold range f arg left in *) (* let arg = f arg key in *) (* range_fold range f arg right *) (* | Leaf -> *) (* arg *) (* * Fold a function over the set. *) let rec fold f arg = function Black (key, left, right, _) | Red (key, left, right, _) -> let arg = fold f arg left in let arg = f arg key in fold f arg right | Leaf -> arg (* * Equality of sets. *) let equal set1 set2 = if cardinality set1 = cardinality set2 then let list1 = to_list set1 in let list2 = to_list set2 in List.for_all2 (fun x y -> Ord.compare x y = 0) list1 list2 else false (* * BUG: these functions are too slow! * Could be much more optimized. *) let filter pred s = fold (fun s' x -> if pred x then add s' x else s') empty s let inter s1 s2 = let size1 = cardinality s1 in let size2 = cardinality s2 in let s1, s2 = if size1 < size2 then s1, s2 else s2, s1 in fold (fun s3 x -> if mem s2 x then add s3 x else s3) empty s1 let partition pred s = fold (fun (s1, s2) x -> if pred x then add s1 x, s2 else s1, add s2 x) (empty, empty) s let rec diff s = function Black (key, left, right, _) | Red (key, left, right, _) -> let s = remove s key in let s = diff s left in diff s right | Leaf -> s let rec subset s1 s2 = match s1 with | Black (key, left, right, _) | Red (key, left, right, _) -> mem s2 key && subset left s2 && subset right s2 | Leaf -> true let compare s1 s2 = let rec compare s1 s2 = match s1, s2 with x1 :: s1, x2 :: s2 -> let cmp = Ord.compare x1 x2 in if cmp = 0 then compare s1 s2 else cmp | [], [] -> 0 | [], _ :: _ -> -1 | _ :: _, [] -> 1 in compare (to_list s1) (to_list s2) (* * Choice. *) let rec min_elt = function Black (key, Leaf, _, _) | Red (key, Leaf, _, _) -> key | Black (_, left, _, _) | Red (_, left, _, _) -> min_elt left | Leaf -> raise Not_found let rec max_elt = function Black (key, _, Leaf, _) | Red (key, _, Leaf, _) -> key | Black (_, _, right, _) | Red (_, _, right, _) -> max_elt right | Leaf -> raise Not_found let choose = min_elt (* * Predicates. *) let rec for_all pred = function Black (key, left, right, _) | Red (key, left, right, _) -> pred key && for_all pred left && for_all pred right | Leaf -> true let rec exists pred = function Black (key, left, right, _) | Red (key, left, right, _) -> pred key || exists pred left || exists pred right | Leaf -> false (* * Width. *) let cardinal = cardinality (* * Filtering operations. *) (* let rec mem_filt s = function *) (* [] -> *) (* [] *) (* | (h :: t) as l -> *) (* if mem s h then *) (* let rem = mem_filt s t in *) (* if rem == t then *) (* l *) (* else *) (* h :: rem *) (* else *) (* mem_filt s t *) (* let rec not_mem_filt s = function *) (* [] -> *) (* [] *) (* | (h :: t) as l -> *) (* if mem s h then *) (* not_mem_filt s t *) (* else *) (* let rem = not_mem_filt s t in *) (* if rem == t then *) (* l *) (* else *) (* h :: rem *) (* let rec fst_mem_filt s = function *) (* [] -> *) (* [] *) (* | (((v, _) as h) :: t) as l -> *) (* if mem s v then *) (* let rem = fst_mem_filt s t in *) (* if rem == t then *) (* l *) (* else *) (* h :: rem *) (* else *) (* fst_mem_filt s t *) end module LmMakeDebug (Ord : Lm_set_sig.OrderedTypeDebug) = struct include LmMake (Ord) let rec pp_print out tree = Lm_printf.fprintf out "@ "; match tree with | Black (key, left, right, size) -> Lm_printf.fprintf out "(@[Black@ %a:%d %a %a)@]" (**) Ord.print key size pp_print left pp_print right | Red (key, left, right, size) -> Lm_printf.fprintf out "(@[Red@ %a:%d %a %a)@]" (**) Ord.print key size pp_print left pp_print right | Leaf -> Lm_printf.pp_print_string out "Leaf" let print = pp_print end omake-0.10.3/src/libmojave/lm_arg.ml0000644000175000017500000005405213177364665015675 0ustar gerdgerd(* * Parsing command line arguments, MCC-style. Arguments to options * may be separated from the option by a space, or may be placed * immediately after the option (without space) IF the option is * not ambiguous. Also, options may be abbreviated as long as the * short form is not ambiguous. * *) (*** Basic Specifications ***) (* spec Argument specification. Each option uses this specification to indicate what type of argument (if any) the option takes. The following option specifications are defined. Unit f: Call an arbitrary function f () Set b: Set the boolean (reference) value b to true Clear b: Set the boolean (reference) value b to false String f: Takes one argument: call function f Int f: Takes one argument: call function f Float f: Takes one argument: call function f Rest f: Call function f , for all remaining arguments section = (name, spec, desc) list Used to define a group of related arguments. (name, spec) indicate the option name and option specification. desc gives a textual description of the option. sections = (desc, section) list Used to define all option groups. Each option group is prefixed by desc which briefly describes the section. *) type 'a poly_spec = (* Imperative versions *) Unit of (unit -> unit) | Set of bool ref | Clear of bool ref | String of (string -> unit) | Int of (int -> unit) | Float of (float -> unit) | Rest of (string -> unit) (* Functional versions *) | UnitFold of ('a -> 'a) | SetFold of ('a -> bool -> 'a) | ClearFold of ('a -> bool -> 'a) | StringFold of ('a -> string -> 'a) | IntFold of ('a -> int -> 'a) | FloatFold of ('a -> float -> 'a) | RestFold of ('a -> string -> 'a) (* Usage message *) | Usage (* spec_mode StrictOptions: options are processed literally, and may not be collapsed into multi-letter options. MultiLetterMode: single-letter options of the form -x may be collapsed into multi-letter options. *) type spec_mode = StrictOptions | MultiLetterOptions type 'a poly_section = (string * 'a poly_spec * string) list type 'a poly_sections = spec_mode * (string * 'a poly_section) list type spec = unit poly_spec type section = unit poly_section type sections = unit poly_sections (* parsing mode StrictMode: options are processed literally, and may not be collapsed into multi-letter options. MultiLetterMode: single-letter options may be collapsed. MultiLetterPending: processing a multi-letter option *) type mode = StrictMode | MultiLetterMode | MultiLetterPending of string * int (* BogusArg Thrown by option processing when something goes wrong... *) exception BogusArg of string (* UsageError Thrown on --help *) exception UsageError (*** Option Table ***) (* CharCompare, CharTable Defines a table indexed by individual characters. *) module CharCompare = struct type t = char let compare (c1 : char) (c2 : char) = if c1 < c2 then -1 else if c1 > c2 then 1 else 0 end (* CharCompare *) module CharTable = Lm_map.LmMake (CharCompare);; (* options The option table is a tree, where each edge is labelled by a character. To lookup the specification for an option, we walk the tree using the characters of the option until we reach a node that has a specification associated with it. This tree is used to help us identify unambiguous prefixes, and also to determine where an option name ends and its value begins (when the name and value are not space-delimited). option_node The type of a node in the options tree. Each node contains a spec if the node matches an option name, and may contain a subtree if there is at least one longer option that has this prefix. SpecNode spec: Leaf node; this branch corresponds to the spec. NameNode tree: No option corresponds to this branch, but there are options in the subtree. SpecOrName (spec, tree): This branch corresponds to an option with the indicated spec; there are also suboptions in the indicated subtree. *) type 'a option_node = SpecNode of 'a poly_spec | NameNode of 'a option_node CharTable.t | SpecOrName of 'a poly_spec * 'a option_node CharTable.t (* is_alnum test if a letter is a letter or number *) let is_alnum = function 'a'..'z' | 'A'..'Z' | '0'..'9' -> true | _ -> false (* char_table_lookup Lookup an entry in the char table. If no entry exists in the table, then None is returned (instead of raising an exception). *) let char_table_lookup table ch = try Some (CharTable.find table ch) with Not_found -> (* If the character is '_', try looking it up as '-'. This is a hack to accomodate both '_' and '-' in option names (proper GCC style uses hyphen, but our old options used underscores). *) if ch = '_' then try Some (CharTable.find table '-') with Not_found -> None else None (* lookup_option We also allow --no-* prefixes on Boolean options. JYH: this is perhaps not the simplest way to deal with inversion, but the implementation is simple. *) let is_invert_prefix name = String.length name > 5 && String.unsafe_get name 0 = '-' && String.unsafe_get name 1 = '-' && String.unsafe_get name 2 = 'n' && String.unsafe_get name 3 = 'o' && String.unsafe_get name 4 = '-' let strip_invert_prefix name = String.sub name 4 (String.length name - 4) let is_invertable_option opt = function Set _ | Clear _ | SetFold _ | ClearFold _ -> String.length opt > 1 && opt.[0] = '-' | _ -> false (* add_option Add a new option name to the option tree. If the exact option already exists, then an exception is thrown. If a prefix or suffix of this option is already defined, then no error occurs. *) let add_option options name spec = if is_invert_prefix name then raise (BogusArg ("Option contains an invertion prefix: " ^ name)); let length = String.length name in (* deconstruct_name Updates the subtree rooted at options, based on the substring of name beginning with offset. *) let rec deconstruct_name options offset = let ch = name.[offset] in let offset = offset + 1 in let entry = if offset < length then (* This is NOT the last character of the option; we need to build a subtree and recurse on ourself. *) match char_table_lookup options ch with None -> NameNode (deconstruct_name CharTable.empty offset) | Some (SpecNode spec') -> SpecOrName (spec', deconstruct_name CharTable.empty offset) | Some (NameNode options) -> NameNode (deconstruct_name options offset) | Some (SpecOrName (spec', options)) -> SpecOrName (spec', deconstruct_name options offset) else (* This is the last character of the option; this is where we might have a duplicate hit, and where we need to drop our specification. *) match char_table_lookup options ch with None -> SpecNode spec | Some (NameNode options) -> SpecOrName (spec, options) | Some _ -> raise (BogusArg ("Duplicate option defined: " ^ name)) in (* Update this node in the tree *) CharTable.add options ch entry in deconstruct_name options 0 (* lookup_option_core Lookup the option with the indicated name in the options tree. If there is an exact option match in the tree, we return the option spec and an empty string. If we hit end up at a node without a spec, but we are an UNAMBIGUOUS prefix of an option in the tree, then we return that option's spec, and an empty string. The final case is more interesting: when we end up at a leaf, then we split the ``name'' we were given into a name/value pair at that point, and return the excess characters as the option's value. This is how we determine when the value associated with an option is not delimited by a space. Note that any option that is a prefix of another option cannot take a value in this way. *) let lookup_option_core options name = let length = String.length name in (* find_branch Checks to see if the subtree rooted at options is a linear branch. If so, return the spec at the end of the branch; otherwise, raise an exception (assuming the option was ambiguous if the branch splits, or that the option is unbound if there is no branch). *) let rec find_branch options = CharTable.fold (fun spec _ options -> match spec, options with None, SpecNode spec -> Some spec | None, NameNode options -> find_branch options | _ -> raise (BogusArg ("Ambiguous option specified: " ^ name))) None options in let find_branch options = match find_branch options with None -> raise (BogusArg ("No such option: " ^ name)) | Some spec -> spec in (* lookup_name Lookup an option in the subtree rooted at options, based on the substring of name beginning at offset. *) let rec lookup_name options offset = let ch = name.[offset] in let offset = offset + 1 in if offset < length then (* We're not at the end of the name we're searching for yet; it is possible that we are looking at a name/value pair. *) match char_table_lookup options ch with None -> (* No option with this prefix was defined *) raise (BogusArg ("No such option: " ^ name)) | Some (SpecNode (Unit _ | Set _ | Clear _ | UnitFold _ | SetFold _ | ClearFold _ | Usage )) -> (* Name was too long; can not assume a name/value pair *) raise (BogusArg ("No such option: " ^ name ^ " (option " ^ (String.sub name 0 offset) ^ " does not take arguments)")) | Some (SpecNode spec) -> (* Name was too long; assume it was a name/value pair *) spec, String.sub name offset (length - offset) | Some (NameNode options) | Some (SpecOrName (_, options)) -> (* Still searching... *) lookup_name options offset else (* Last character in the name we were given; this is either an exact match, or (hopefully) an unambiguous prefix of an option in the tree. *) match char_table_lookup options ch with None -> (* Last char of name, not no option matches *) raise (BogusArg ("No such option: " ^ name)) | Some (SpecNode spec) | Some (SpecOrName (spec, _)) -> (* Exact match to an option in the tree. *) spec, "" | Some (NameNode options) -> (* Inexact match; try to find a branch. *) find_branch options, "" in lookup_name options 0 exception Invert let lookup_option options name = if is_invert_prefix name then let orig_name = strip_invert_prefix name in try match lookup_option_core options orig_name with Set f, "" -> Clear f, "" | SetFold f, "" -> ClearFold f, "" | Clear f, "" -> Set f, "" | ClearFold f, "" -> SetFold f, "" | _ -> raise Invert with BogusArg _ | Not_found -> raise (BogusArg ("No such option: " ^ orig_name ^ " (extracted from inverted: " ^ name ^ ")")) | Invert -> raise (BogusArg ("Not an invertable option: " ^ orig_name ^ " (extracted from inverted: " ^ name ^ ")")) else lookup_option_core options name (* compute_option_tree Convert a sections spec into an option tree. Can raise an exception if the sections spec contains duplicate options. *) let compute_option_tree spec = let options = CharTable.empty in let options = List.fold_left (fun options (_, spec_block) -> List.fold_left (fun options (name, spec, _) -> add_option options name spec) options spec_block) options spec in options (*** Help System ***) (* Wraps at terminal width *) let rec print_doc_string opt_width s = let width = Lm_termsize.stdout_width - opt_width in let margin = "\n" ^ String.make opt_width ' ' in let len = String.length s in if len <= width then Lm_printf.print_string s else if String.rcontains_from s width ' ' then begin let i = String.rindex_from s width ' ' in Lm_printf.print_string (String.sub s 0 i); Lm_printf.print_string margin; print_doc_string opt_width (String.sub s (i+1) (len - i - 1)) end else begin Lm_printf.print_string (String.sub s 0 width); Lm_printf.print_string margin; print_doc_string opt_width (String.sub s width (len - width)) end let usage_arg = function Unit _ | Set _ | Clear _ | UnitFold _ | SetFold _ | ClearFold _ | Usage -> "" | String _ | StringFold _ -> " " | Int _ | IntFold _ -> " " | Float _ | FloatFold _ -> " " | Rest _ | RestFold _ -> " ..." (* usage Display the usage message and help text for the options. *) let usage opt_width spec = List.iter (fun (opt, spec, doc) -> (* Descriptive text for the option argument *) let opt = opt ^ (usage_arg spec) in (* Display information on a single option. *) (if String.length opt > opt_width then (* option name too long to fit on one line *) Lm_printf.printf "@ %s@ %*s" opt opt_width "" else Lm_printf.printf "@ %-*s" opt_width opt); (if is_invertable_option opt spec then Lm_printf.printf "*: " else Lm_printf.printf " : "); print_doc_string (opt_width + 7) doc) spec let usage_length (opt, spec, _) = String.length opt + String.length (usage_arg spec) let usage (mode, spec) usage_msg = (* Display help for all sections. *) let opt_max_length = List.fold_left (fun i (_, spec) -> (List.fold_left (fun i opt -> max i (usage_length opt))) i spec) 0 spec in let opt_width = min opt_max_length ((max 80 Lm_termsize.stdout_width) / 3 - 7) in Lm_printf.printf "@[%s." usage_msg; List.iter (fun (section, spec) -> Lm_printf.printf "@ @ @[%s:" section; usage opt_width spec; Lm_printf.printf "@]") spec; (match mode with StrictOptions -> () | MultiLetterOptions -> Lm_printf.printf "@ Single-letter options may be concatenated as part of a single option."); (if List.exists (fun (_, spec) -> List.exists (fun (opt, spec, _) -> is_invertable_option opt spec) spec) spec then Lm_printf.printf "@ @ (*) Prefix the option with \"--no\" to disable."); Lm_printf.printf "@]@." (*** Option Processing ***) (* pending_arguments Query for pending arguments or options. Advances the parser for the current mode, and returns a pair (mode, found), where found is true iff there are options or arguments left to process. *) let advance_options mode _argv argv_length current = match mode with StrictMode | MultiLetterMode -> mode, current < argv_length | MultiLetterPending (opt, i) when i = String.length opt -> MultiLetterMode, current < argv_length | MultiLetterPending _ -> mode, true (* get_next_arg Get the next argument in the argument stream. Returns the argument string, as well as the new current marker. *) let get_next_arg opt argv argv_length current = if current < argv_length then argv.(current), current + 1 else if (opt <> "") then raise (BogusArg ("Option " ^ opt ^ " requires an argument")) else raise (Invalid_argument "Lm_arg: internal error") (* get_next_option In StrictMode, this is the same as get_next_arg. In MultiLetterMode, this walks letter-by-letter through simple options. *) let rec get_next_option mode argv argv_length current = match mode with StrictMode -> let opt, current = get_next_arg "" argv argv_length current in opt, current, mode | MultiLetterMode -> (* See if the next argument is an option *) let opt, current = get_next_arg "" argv argv_length current in if String.length opt >= 2 && opt.[0] = '-' && is_alnum opt.[1] then get_next_option (MultiLetterPending (opt, 1)) argv argv_length current else opt, current, mode | MultiLetterPending (opt, i) -> let s = "-" ^ String.make 1 opt.[i] in let mode = MultiLetterPending (opt, succ i) in s, current, mode (* parse Parses the program arguments, using a sections specification. Any non-option argument is passed to the default function, in order; if -help or --help is intercepted on the argument stream, then the usage message is displayed. *) let fold_argv argv (mode_info, spec_info) arg default usage_msg = (* Always add the --help flag *) let spec_info = ("Help flags", ["--help", Usage, "Display a help message"]) :: spec_info in (* Set the current mode *) let mode = match mode_info with | StrictOptions -> StrictMode | MultiLetterOptions -> MultiLetterMode in (* Convert spec into an options tree, for easier parsing *) let options = compute_option_tree spec_info in let argv_length = Array.length argv in (* * Parse a single option. * arg: the fold value being computed * current: the current index into argv *) let rec parse_option mode arg current = let mode, pending = advance_options mode argv argv_length current in if pending then (* Get the name of the option *) let opt, current, mode = get_next_option mode argv argv_length current in let current, arg = if String.length opt > 0 && opt.[0] = '-' then (* Get information on the option *) let spec, s = lookup_option options opt in (* If no value was embedded in the option, but the option requires a value, then grab the next argument for its value. *) let s, current, arg = match spec, s with String _, "" | Int _, "" | Float _, "" | StringFold _, "" | IntFold _, "" | FloatFold _, "" -> let s, current = get_next_arg opt argv argv_length current in s, current, arg | Unit _, "" | Set _, "" | Clear _, "" | Usage, "" | UnitFold _, "" | SetFold _, "" | ClearFold _, "" | String _, _ | Int _, _ | Float _, _ | StringFold _, _ | IntFold _, _ | FloatFold _, _ -> s, current, arg | Rest f, "" -> let rec rest_function current = if current < argv_length then begin f argv.(current); rest_function (current + 1) end else "", current, arg in rest_function current | RestFold f, "" -> let rec rest_function arg current = if current < argv_length then rest_function (f arg argv.(current)) (current + 1) else "", current, arg in rest_function arg current | _ -> raise (Invalid_argument "Lm_arg: internal error") in (* Actually process the option. *) let arg = match spec with Unit f -> f (); arg | UnitFold f -> f arg | Set x -> x := true; arg | SetFold f -> f arg true; | Clear x -> x := false; arg | ClearFold f -> f arg false | String f -> f s; arg | StringFold f -> f arg s | Int f -> f (int_of_string s); arg | IntFold f -> f arg (int_of_string s) | Float f -> f (float_of_string s); arg | FloatFold f -> f arg (float_of_string s) | Rest _ | RestFold _ -> arg | Usage -> usage (mode_info, spec_info) usage_msg; raise UsageError in current, arg else (* Not an option; pass to the default function *) let arg, rest = default arg opt in if rest then let rec rest_function arg current = if current < argv_length then let arg, _ = default arg argv.(current) in rest_function arg (current + 1) else current, arg in rest_function arg current else current, arg in (* We're done with this option, advance to next *) parse_option mode arg current else current, arg in let _, arg = parse_option mode arg 1 in arg let fold spec arg default usage_msg = fold_argv Sys.argv spec arg default usage_msg let parse_argv argv spec default usage_msg = fold_argv argv spec () (fun () opt -> default opt, false) usage_msg let parse spec default usage_msg = fold spec () (fun () opt -> default opt, false) usage_msg omake-0.10.3/src/libmojave/lm_hash.ml0000644000175000017500000001572213177364665016050 0ustar gerdgerd (* %%MAGICBEGIN%% *) type 'a marshal_item = { mutable item_ref : unit ref; mutable item_val : 'a; item_hash : int } (* %%MAGICEND%% *) (* * A version with two equalities. * The fine equality is used for cons-hashing, but the coarse * version is used for external comparisons. The fine equality * must be a refinement of the coarse equality. *) (* %%MAGICBEGIN%% *) type 'a marshal_eq_item = ('a * 'a marshal_item) marshal_item (* %%MAGICEND%% *) (* * Statistics. *) type stat = { debug : string; mutable reintern : int; mutable compare : int; mutable collisions : int } let current_ref = ref () let stats = ref [] let pp_print_stat buf ({ debug = debug; reintern = reintern; compare = compare; collisions = collisions } : stat) = Format.fprintf buf "@[%s: reintern = %d, compare = %d, collisions = %d@]@\n" (**) debug reintern compare collisions let pp_print_stats buf = List.iter (pp_print_stat buf) !stats (* let () = *) (* at_exit (fun () -> pp_print_stats Format.err_formatter) *) module type MARSHAL = sig type t (* For debugging *) val debug : string (* The client needs to provide hash and comparison functions *) val hash : t -> int val compare : t -> t -> int val reintern : t -> t end module type MARSHAL_EQ = sig type t (* For debugging *) val debug : string (* * The client needs to provide the hash and the two comparison functions. *) val fine_hash : t -> int val fine_compare : t -> t -> int val coarse_hash : t -> int val coarse_compare : t -> t -> int (* Rehash the value *) val reintern : t -> t end (* * This is what we get. *) module type HashMarshalSig = sig type elt type t (* Creation *) val create : elt -> t (* Destructors *) val get : t -> elt val hash : t -> int (* Comparison *) val equal : t -> t -> bool val compare : t -> t -> int (* Rehash the value *) val reintern : t -> t end module type HashMarshalEqSig = sig include HashMarshalSig (* The default equality is the coarse one *) val fine_hash : t -> int val fine_compare : t -> t -> int val fine_equal : t -> t -> bool end (* * Make a hash item. *) module MakeCoarse (Arg : MARSHAL) = struct type elt = Arg.t type t = elt marshal_item (* Keep a hash-cons table based on a weak comparison *) module WeakCompare = struct type t = elt marshal_item let compare (item1 : t) (item2 : t) = let hash1 = item1.item_hash in let hash2 = item2.item_hash in if hash1 < hash2 then -1 else if hash1 > hash2 then 1 else Arg.compare item1.item_val item2.item_val end;; module Table = Lm_map.LmMake (WeakCompare);; let table = ref Table.empty (* * Keep track of collisions for debugging. *) let stat = { debug = Arg.debug; reintern = 0; compare = 0; collisions = 0 } let () = stats := stat :: !stats let create = Lm_thread.Synchronize.synchronize begin function elt -> let item : _ marshal_item = { item_ref = current_ref; item_val = elt; item_hash = Arg.hash elt } in try Table.find !table item with Not_found -> table := Table.add !table item item; item end (* * Reintern. This will take an item that may-or-may-not be hashed * and produce a new one that is hashed. *) let reintern = Lm_thread.Synchronize.synchronize begin function item1 -> stat.reintern <- stat.reintern + 1; match Table.find !table item1 with | item2 -> (* assert (item2 = item1 ); *) if item2 != item1 then begin item1.item_val <- item2.item_val; item1.item_ref <- current_ref end; item2 | exception Not_found -> item1.item_val <- Arg.reintern item1.item_val; item1.item_ref <- current_ref; table := Table.add !table item1 item1; item1 end (* * Access to the element. *) let get (item : _ marshal_item) = if item.item_ref == current_ref then item.item_val else (reintern item).item_val let hash item = item.item_hash (* * String pointer-based comparison. *) let compare (item1 : t) (item2 : t) = stat.compare <- stat.compare + 1; let hash1 = item1.item_hash in let hash2 = item2.item_hash in if hash1 < hash2 then -1 else if hash1 > hash2 then 1 else if item1.item_val == item2.item_val then 0 else let elt1 = get item1 in let elt2 = get item2 in if elt1 == elt2 then 0 else begin stat.collisions <- stat.collisions + 1; let cmp = Arg.compare elt1 elt2 in if cmp = 0 then invalid_arg "Lm_hash is broken@."; cmp end let equal (item1 : t) (item2 : t) = (item1 == item2) || (item1.item_hash = item2.item_hash && get item1 == get item2) end module MakeFine (Arg : MARSHAL_EQ) = struct type elt = Arg.t type t = elt marshal_eq_item module CoarseArg = struct type t = Arg.t let debug = Arg.debug ^ ":coarse" let hash = Arg.coarse_hash let compare = Arg.coarse_compare let reintern = Arg.reintern end;; module Coarse = MakeCoarse (CoarseArg);; (* * We fold the Coarse item into the fine * item only so we don't have to create three * modules (the final one being a pair of fine * and coarse). *) module FineArg = struct type t = Arg.t * Coarse.t let debug = Arg.debug ^ ":fine" (* * We're assuming that the fine hash is a * refinement of the coarse one. *) let hash (fine, _) = Arg.fine_hash fine let compare (fine1, _) (fine2, _) = Arg.fine_compare fine1 fine2 let reintern ((fine, coarse) as item) = let fine' = Arg.reintern fine in let coarse' = Coarse.reintern coarse in if fine' == fine && coarse' == coarse then item else fine', coarse' end;; module Fine = MakeCoarse (FineArg);; let create x = Fine.create (x, Coarse.create x) let get info = fst (Fine.get info) (* * The default functions are the coarse versions. *) let get_coarse (info : t) = snd (Fine.get info) let hash (info : t) : int = Coarse.hash (get_coarse info) let compare item1 item2 = Coarse.compare (get_coarse item1) (get_coarse item2) let equal item1 item2 = Coarse.equal (get_coarse item1) (get_coarse item2) (* * Also export the fine versions. *) let fine_hash = Fine.hash let fine_compare = Fine.compare let fine_equal = Fine.equal let reintern = Fine.reintern end omake-0.10.3/src/libmojave/lm_wild.ml0000644000175000017500000000423613177364665016062 0ustar gerdgerdlet wild_char = '%' let wild_string = "%" (* * We have very simple regular expressions of the form, where * a single % is a wildcard. *) type in_patt = int * string * int * string type out_patt = string list type subst = int * string (* * Printing. *) let pp_print_wild_in buf (_, s1, _, s2) = Format.fprintf buf "%s%c%s" s1 wild_char s2 let pp_print_wild_out buf strs = Lm_printf.pp_print_string buf (String.concat wild_string strs) let is_wild s = String.contains s wild_char (* * Compile a pattern to make searching easier. *) let compile_in s = let len = String.length s in match String.index s wild_char with | index -> let prefix = String.sub s 0 index in let slen = len - index - 1 in let suffix = String.sub s (index + 1) slen in if String.contains suffix wild_char then raise (Failure "Only one wildcard symbol % allowed in a match pattern"); index, prefix, slen, suffix | exception Not_found -> raise (Invalid_argument "Lm_wild.wild_compile") let compile_out s = Lm_string_util.split wild_string s (* * Match the wild pattern, and return a subst. *) let wild_match (plen, prefix, slen, suffix) s = let len = String.length s in if len >= plen + slen then try begin let soffs = len-slen in for i = slen - 1 downto 0 do if String.unsafe_get suffix i = String.unsafe_get s (soffs + i) then () else raise Not_found done; for i = 0 to plen - 1 do if String.unsafe_get prefix i = String.unsafe_get s i then () else raise Not_found done end; let len = len - plen - slen in Some (len, String.sub s plen len) with Not_found -> None else None (* * Get the substitution value. *) let core (_, s) = s let of_core s = String.length s, s (* * Perform a substitution. *) let subst_in (slen, s) (plen, prefix, sflen, suffix) = let res = Bytes.create (slen + plen + sflen) in String.blit prefix 0 res 0 plen; String.blit s 0 res plen slen; String.blit suffix 0 res (plen + slen) sflen; Bytes.to_string res let subst (_, s) strs = String.concat s strs omake-0.10.3/src/libmojave/lm_heap.ml0000755000175000017500000000063413177364665016041 0ustar gerdgerd(* * This is mainly for debugging. It will rarely used, if ever, * but it may be some help in tracking down GC problems. *) (* open Lm_printf *) (* external lm_heap_check : string -> unit = "lm_heap_check" *) (* let heap_check debug = *) (* eprintf "%s: start@." debug; *) (* lm_heap_check debug; *) (* eprintf "%s: heap checked@." debug *) (* * Normally disabled. *) let heap_check _ = () omake-0.10.3/src/libmojave/lm_uname.ml0000644000175000017500000000054713177364665016231 0ustar gerdgerd type uname = { sysname : string; nodename : string; release : string; version : string; machine : string } external lm_uname : unit -> uname = "lm_uname" let uname = lm_uname () let sysname = uname.sysname let nodename = uname.nodename let release = uname.release let version = uname.version let machine = uname.machine omake-0.10.3/src/libmojave/lm_debug.ml0000644000175000017500000001311513177364665016205 0ustar gerdgerd (* * Info needed for a debug variable. *) type debug_info = { debug_name : string; debug_description : string; debug_value : bool } (* * Info about variables. *) type info = { info_name : string; mutable info_info : string option; info_flag : bool ref } (* * Perform debugging? * Set this function to false to disable all debugging. *) let debug_enabled = true let debug flag = debug_enabled && !flag (* Initial info is empty. *) let info = ref [] (* Description of debug flags added from the command line. *) (* let default_description = "Unitialized debug flag" *) (* List all the debug flags. *) (* let debuggers () = *) (* let collect { info_name = name; info_info = info; info_flag = flag } = *) (* let info = *) (* match info with *) (* |Some info -> *) (* info *) (* | None -> *) (* default_description in *) (* { debug_name = name; debug_description = info; debug_value = !flag } *) (* in *) (* Array.of_list (List.map collect !info) *) (* * Print a usage argument. *) (* let debug_usage () = *) (* let usage { debug_name = name; debug_description = desc; debug_value = flag } = *) (* Printf.eprintf "\t%s: %s: %b\n" name desc flag in *) (* Printf.eprintf "Debugging flags:\n"; *) (* Printf.eprintf "You can specify these as a colon-separated list\n"; *) (* Array.iter usage (debuggers ()); *) (* flush stderr *) (* Create a debugging variable. *) let create_debug { debug_name = name; debug_description = desc; debug_value = flag } = let rec search = function | ({ info_name = name'; info_info = desc'; info_flag = flag' } as x) :: t -> if name = name' then begin match desc' with | None -> x.info_info <- Some desc; flag' | Some desc' -> if desc <> desc' then raise (Failure (Printf.sprintf "Lm_debug.create_debug: variable '%s' is already created with a different description" name)) else flag' end else search t | [] -> let flag' = ref flag in info := { info_name = name; info_info = Some desc; info_flag = flag' } :: !info; flag' in search !info (* * Modify a debugging flag. *) (* let set_debug name flag = *) (* let rec search = function *) (* h :: t -> *) (* let { info_name = name'; info_flag = flag'; _ } = h in *) (* if name' = name then *) (* flag' := flag *) (* else *) (* search t *) (* | [] -> raise (Failure "set_debug") *) (* in *) (* search !info *) (* * Possible debug flag. * Try setting the flag first. *) (* let set_possible_debug name flag = *) (* try set_debug name flag with *) (* Failure "set_debug" -> *) (* let flag' = ref flag in *) (* let ninfo = *) (* { info_name = name; *) (* info_info = None; *) (* info_flag = flag' *) (* } *) (* in *) (* info := ninfo :: !info *) (************************************************************************ * PARTICULAR DEBUG * ************************************************************************) (* * File loading. *) let debug_load = create_debug (**) { debug_name = "load"; debug_description = "Print file names as they load"; debug_value = false } let eflush outx = output_char outx '\n'; flush outx let show_loading s = if !debug_load then Printf.eprintf s eflush (* * Split a string at a particular char. *) (* let split c s = *) (* let len = String.length s in *) (* let rec loop i j = *) (* if j = len then *) (* if i = j then *) (* [] *) (* else *) (* [String.sub s i (j - i)] *) (* else if String.contains c s.[j] then *) (* if i = j then *) (* loop (j + 1 ) (j + 1) *) (* else *) (* String.sub s i (j - i) :: loop ( j + 1) ( j + 1) *) (* else *) (* loop i (succ j) *) (* in *) (* loop 0 0 *) (************************************************************************* * AD-HOC PROFILING *) (* open Unix *) type times = { mutable calls : int; mutable wtime : float; mutable utime : float; mutable stime : float } type profile = { ok : times; exn : times } (* type 'a res = *) (* | Ok of 'a *) (* | Exn of exn *) let tbl = Hashtbl.create 19 let compare (_,t1) (_,t2) = Pervasives.compare (t1.ok.wtime +. t1.exn.wtime) (t2.ok.wtime +. t2.exn.wtime) let report1 s t = let calls_f = float_of_int t.calls in Printf.eprintf "\t%s:\n\t\tCalls: %i;\n\t\tTime elapsed: %0.3fs (%0.6fs/call);\n\t\tSystem time: %0.2fs (%0.6fs/call);\n\t\tUser time: %0.2fs (%0.6fs/call).\n" (**) s t.calls t.wtime (t.wtime /. calls_f) t.stime (t.stime /. calls_f) t.utime (t.utime /. calls_f) let report (s, t) = Printf.eprintf "Timing information for %s (%0.3fs total):\n" s (t.ok.wtime +. t.exn.wtime); if t.ok.calls <> 0 then report1 (if t.exn.calls <> 0 then "Successful calls" else "All calls succeeded") t.ok; if t.exn.calls <> 0 then report1 (if t.ok.calls <> 0 then "Failed calls" else "All calls failed") t.exn; if t.ok.calls <> 0 && t.exn.calls <> 0 then report1 "Total calls" { calls = t.ok.calls + t.exn.calls; wtime = t.ok.wtime +. t.exn.wtime; utime = t.ok.utime +. t.exn.utime; stime = t.ok.stime +. t.exn.stime } let add s t l = (s,t) :: l let report_timing () = if Hashtbl.length tbl > 0 then List.iter report (List.sort compare (Hashtbl.fold add tbl [])) let () = at_exit report_timing omake-0.10.3/src/libmojave/lm_index.ml0000644000175000017500000003766513177364665016246 0ustar gerdgerd(* * Index module based on tables. * An index is essentially a multi-level table. * Each entry has an associated data item and subtable. * * ---------------------------------------------------------------- * * Copyright (C) 2002 Michael Maire, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Michael Maire * mmaire@caltech.edu * * ---------------------------------------------------------------- * Revision History * * 2002 Apr 20 Michael Maire Initial Version * 2002 Apr 25 Michael Maire Renamed iter, maps, folds to *_all * added single level iters, maps, folds * 2002 Apr 26 Michael Maire Added functions for explicitly adding * subindices * 2002 May 1 Michael Maire Made all adds nondestructive towards * subindices (if subindex is not explicitly * specified in the add) * Changed interface *) (* * Elements. * This type specifies the type of the keys used in the index. *) module type OrderedType = sig type t val compare : t -> t -> int end (* * These are the functions provided by the index. *) module type LmIndex = sig (* index maps key lists to elements of type 'a *) type key type 'a t (* empty index and empty test *) val empty : 'a t val is_empty : 'a t -> bool (* tests/lookups - single level*) val mem : 'a t -> key -> bool val find : 'a t -> key -> 'a t * 'a val find_index : 'a t -> key -> 'a t val find_data : 'a t -> key -> 'a (* tests/lookups - multi level*) val mem_list : 'a t -> key list -> bool val find_list : 'a t -> key list -> 'a t * 'a val find_list_index : 'a t -> key list -> 'a t val find_list_data : 'a t -> key list -> 'a (* addition and removal - single level*) val add : 'a t -> key -> 'a -> 'a t val add_i : 'a t -> key -> 'a t * 'a -> 'a t val remove : 'a t -> key -> 'a t (* addition of a chain of nested entries *) val add_list : 'a t -> key list -> 'a list -> 'a t val add_list_i : 'a t -> key list -> ('a t * 'a) list -> 'a t (* addition/removal of single entries *) val add_entry : 'a t -> key list -> 'a -> 'a t val add_entry_i : 'a t -> key list -> 'a t * 'a -> 'a t val remove_entry : 'a t -> key list -> 'a t (* filter addition/removal - single level *) val filter_add : 'a t -> key -> ('a option -> 'a) -> 'a t val filter_add_i : 'a t -> key -> (('a t * 'a) option -> ('a t * 'a)) -> 'a t val filter_remove : 'a t -> key -> ('a -> 'a option) -> 'a t val filter_remove_i : 'a t -> key -> (('a t * 'a) -> ('a t * 'a) option) -> 'a t (* filter addition of a chain of nested entries *) val filter_add_list : 'a t -> key list -> ('a option -> 'a) list -> 'a t val filter_add_list_i : 'a t -> key list -> (('a t * 'a) option -> ('a t * 'a)) list -> 'a t (* filter addition/removal of single entries *) val filter_add_entry : 'a t -> key list -> ('a option -> 'a) -> 'a t val filter_add_entry_i : 'a t -> key list -> (('a t * 'a) option -> ('a t * 'a)) -> 'a t val filter_remove_entry : 'a t -> key list -> ('a -> 'a option) -> 'a t val filter_remove_entry_i : 'a t -> key list -> (('a t * 'a) -> ('a t * 'a) option) -> 'a t (* iterators, maps, and folds - single level *) val iter : (key -> ('a t * 'a) -> unit) -> 'a t -> unit val map : (('a t * 'a) -> ('b t * 'b)) -> 'a t -> 'b t val mapi : (key -> ('a t * 'a) -> ('b t * 'b)) -> 'a t -> 'b t val fold : ('a -> key -> ('b t * 'b) -> 'a) -> 'a -> 'b t -> 'a val fold_map : ('a -> key -> ('b t * 'b) -> 'a * ('c t * 'c)) -> 'a -> 'b t -> 'a * 'c t (* iterators, maps, and folds - entire index *) val iter_all : (key list -> 'a -> unit) -> 'a t -> unit val map_all : ('a -> 'b) -> 'a t -> 'b t val mapi_all : (key list -> 'a -> 'b) -> 'a t -> 'b t val fold_all : ('a -> key list -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold_map_all : ('a -> key list -> 'b -> 'a * 'c) -> 'a -> 'b t -> 'a * 'c t end (* * Make the index. *) module LmMake (Base : OrderedType) : LmIndex with type key = Base.t = struct (* * Construct table type for elements. *) module EltTable = Lm_map.LmMake (Base) (* * An index is a tree of nested tables. *) type ('elt, 'data) tree = Leaf | Index of (('elt, 'data) tree * 'data) EltTable.t type key = Base.t type 'a t = (key, 'a) tree (* * An empty index is a leaf. *) let empty = Leaf (* * Test if index is empty. *) let is_empty = function Leaf -> true | Index _ -> false (* * Test membership of a key in an index. *) let mem index key = match index with Leaf -> false | Index table -> EltTable.mem table key (* * Lookup a key in an index. *) let find index key = match index with Leaf -> raise Not_found | Index table -> EltTable.find table key (* * Lookup the subindex for a key in an index. *) let find_index index key = let index, _ = find index key in index (* * Lookup the data for a key in an index. *) let find_data index key = let _, data = find index key in data (* * Test for membership of a key sequence in an index. *) let rec mem_list index keys = match keys with [] -> false | key :: [] -> mem index key | key :: keys -> let index = find_index index key in mem_list index keys (* * Lookup a key sequence in an index. *) let rec find_list index keys = match keys with [] -> raise Not_found | key :: [] -> find index key | key :: keys -> let index = find_index index key in find_list index keys (* * Lookup the subindex for a key sequence. *) let find_list_index index keys = let index, _ = find_list index keys in index (* * Lookup the data for a key sequence. *) let find_list_data index keys = let _, data = find_list index keys in data (* * Lookup subindex and data for a key, return an option. *) let find_opt index key = try Some (find index key) with Not_found -> None (* * Lookup subindex for a key, return an option. *) (* let find_index_opt index key = *) (* try *) (* Some (find_index index key) *) (* with *) (* Not_found -> *) (* None *) (* * Lookup data for key, return an option (Some data or None). *) (* let find_data_opt index key = *) (* try *) (* Some (find_data index key) *) (* with *) (* Not_found -> *) (* None *) (* * Filter add a (key, (index, data)) pair to an index. *) let filter_add_i index key f = match index with Leaf -> Index (EltTable.add (EltTable.empty) key (f None)) | Index table -> let i_entry = find_opt index key in Index (EltTable.add table key (f i_entry)) (* * Filter add a (key, data) pair to an index. *) let filter_add index key f = filter_add_i index key ( fun i_entry -> match i_entry with None -> Leaf, f None | Some (i, d) -> i, f (Some d) ) (* * Filter remove a key from an index using its (index, data) entry *) let filter_remove_i index key f = match index with Leaf -> Leaf | Index table -> let i_entry = f (find index key) in match i_entry with Some _ -> Index (EltTable.remove table key) | None -> index (* * Filter remove a key from an index using its data. *) let filter_remove index key f = filter_remove_i index key ( fun (i, d) -> match (f d) with Some d -> Some (i, d) | None -> None ) (* * Filter add a chain of (key, (index, data)) pairs to an index. *) let rec filter_add_list_i index keys fs = match keys, fs with [], [] -> index | key :: [], f :: [] -> filter_add_i index key f | key :: keys, f :: fs -> let index = filter_add_i index key f in let subindex, data = find index key in let subindex = filter_add_list_i subindex keys fs in filter_add_i index key (fun _ -> subindex, data) | _ -> raise (Invalid_argument "filter_add_list_i") (* * Filter add a chain of (key, data) pairs to an index. *) let rec filter_add_list index keys fs = match keys, fs with [], [] -> index | key :: [], f :: [] -> filter_add index key f | key :: keys, f :: fs -> let index = filter_add index key f in let subindex, data = find index key in let subindex = filter_add_list subindex keys fs in filter_add_i index key (fun _ -> subindex, data) | _ -> raise (Invalid_argument "filter_add_list") (* * Filter add an (index, data) entry at the end of a chain in the index. *) let rec filter_add_entry_i index keys f = match keys with [] -> index | key :: [] -> filter_add_i index key f | key :: keys -> let subindex, data = find index key in let subindex = filter_add_entry_i subindex keys f in filter_add_i index key (fun _ -> subindex, data) (* * Filter add a data entry at the end of a chain in the index. *) let filter_add_entry index keys f = filter_add_entry_i index keys ( fun i_entry -> match i_entry with None -> Leaf, f None | Some (i, d) -> i, f (Some d) ) (* * Filter remove an (index, data) entry at the end of a chain in the index. *) let rec filter_remove_entry_i index keys f = match keys with [] -> index | key :: [] -> filter_remove_i index key f | key :: keys -> let subindex, data = find index key in let subindex = filter_remove_entry_i subindex keys f in filter_add_i index key (fun _ -> subindex, data) (* * Filter remove a data entry at the end of a chain in the index. *) let filter_remove_entry index keys f = filter_remove_entry_i index keys ( fun (i, d) -> match (f d) with Some d -> Some (i, d) | None -> None ) (* * Add a (key, data) pair to an index. *) let add index key data = filter_add index key (fun _ -> data) (* * Add a (key, (index, data)) pair to an index. *) let add_i index key i_entry = filter_add_i index key (fun _ -> i_entry) (* * Remove a key from an index. *) let remove index key = filter_remove index key (fun data -> Some data) (* * Add a chain of (key, data) pairs to an index. *) let add_list index keys datas = let fs = List.map (fun data -> (fun _ -> data)) datas in filter_add_list index keys fs (* * Add a chain of (key, (index, data)) pairs to an index. *) let add_list_i index keys i_entries = let fs = List.map (fun i_entry -> (fun _ -> i_entry)) i_entries in filter_add_list_i index keys fs (* * Add a data entry at the end of a chain in the index. *) let add_entry index keys data = filter_add_entry index keys (fun _ -> data) (* * Add an (index, data) entry at the end of a chain in the index. *) let add_entry_i index keys i_entry = filter_add_entry_i index keys (fun _ -> i_entry) (* * Remove an entry at the end of a chain in the index. *) let remove_entry index keys = filter_remove_entry index keys (fun data -> Some data) (* * Iterate over the top level entries. *) let iter f = function Leaf -> () | Index table -> EltTable.iter f table (* * Apply map to the top level entries. *) let map f = function Leaf -> Leaf | Index table -> Index (EltTable.map f table) (* * Apply map to top level entries using keys. *) let mapi f = function Leaf -> Leaf | Index table -> Index (EltTable.mapi f table) (* * Fold over top level entries. *) let fold f data = function Leaf -> data | Index table -> EltTable.fold f data table (* * Fold map over top level entries. *) let fold_map f data = function Leaf -> data, Leaf | Index table -> let data', table' = EltTable.fold_map f data table in data', Index (table') (* * Iterate over every entry in the index. *) let rec iter_all_list f keys = function Leaf -> () | Index table -> EltTable.iter ( fun key (index, data) -> let keys = keys @ [key] in f keys data; iter_all_list f keys index ) table let iter_all f index = iter_all_list f [] index (* * Apply map to every element in the index. *) let rec map_all f = function Leaf -> Leaf | Index table -> Index ( EltTable.map ( fun (index, data) -> (map_all f index, f data) ) table ) (* * Apply map using keys. *) let rec mapi_all_list f keys = function Leaf -> Leaf | Index table -> Index ( EltTable.mapi ( fun key (index, data) -> let keys = keys @ [key] in (mapi_all_list f keys index, f keys data) ) table ) let mapi_all f index = mapi_all_list f [] index (* * Fold over the index. *) let rec fold_all_list f keys data = function Leaf -> data | Index table -> EltTable.fold ( fun a key (index, b) -> let keys = keys @ [key] in (fold_all_list f keys (f a keys b) index) ) data table let fold_all f data index = fold_all_list f [] data index (* * Fold map over the index. *) let rec fold_map_all_list f keys data = function Leaf -> data, Leaf | Index table -> let data', table' = EltTable.fold_map ( fun a key (index, b) -> let keys = keys @ [key] in let res_a, res_c = f a keys b in let res_a', index' = fold_map_all_list f keys res_a index in res_a', (index', res_c) ) data table in data', Index (table') let fold_map_all f data index = fold_map_all_list f [] data index end omake-0.10.3/src/libmojave/lm_thread.ml0000644000175000017500000005160713177364665016376 0ustar gerdgerd(** Our personal implementation of threads. Each thread has thread-local state. *) let debug_lock = Lm_debug.create_debug (**) { debug_name = "lock"; debug_description = "Show locking operations"; debug_value = false } module Mutex = Lm_thread_core.MutexCore module Condition = Lm_thread_core.ConditionCore (* module MutexDebug = MutexCoreDebug *) (* module ConditionDebug = ConditionCoreDebug *) (* * The state identifier is just an integer. *) type state_id = int (* * Each thread has a translation to a state, * and a condition variable for blocking the thread. * When the thread has a lock, the operation is set * to the state of the lock. *) type thread = { thread_id : int; thread_parent : int; thread_cond : Condition.t; mutable thread_state : state_id } type thread_request = RequestRead of thread | RequestWrite of thread (* * A handle is a particular copy of a value. * handle_value: the actual data value * handle_queue: the queue of waiting threads * handle_state: the current active state * handle_active: a table of the currently active threads * handle_readers: the number of active readers * handle_writers: the number of active and queued writers *) type handle_state = HandleUnlocked | HandleReading | HandleWriting type handle_mode = ModeReading | ModeWriting type 'a handle = { handle_value : 'a; handle_debug : string; handle_queue : thread_request Queue.t; mutable handle_state : handle_state; mutable handle_readers : int; mutable handle_writers : int; mutable handle_active : handle_mode Lm_int_set.IntTable.t } (* * The info struct is the table of handles for all threads * for this specific value. *) type 'a info = { info_default : 'a; info_debug : string; info_fork : ('a -> 'a); mutable info_forks : Lm_int_set.IntSet.t; mutable info_entries : 'a handle Lm_int_set.IntTable.t } (* * An entry corresponds to a single data value. * The value can be shared by all threads, or * each thread may have a private copy. *) type 'a entry = EntryShared of 'a handle | EntryPrivate of 'a info (* * The state has: * state_lock: a master lock * state_index: the index for the next state to be allocated. * state_threads: info for each thread we know about *) type state = { state_lock : Mutex.t; mutable state_index : int; mutable state_threads : thread Lm_int_set.IntTable.t } let state = let thread_id = Lm_thread_core.ThreadCore.id (Lm_thread_core.ThreadCore.self ()) in let current = { thread_id = thread_id; thread_parent = thread_id; thread_cond = Condition.create (); thread_state = 1 } in { state_lock = Mutex.create "Lm_thread.state"; state_threads = Lm_int_set.IntTable.add Lm_int_set.IntTable.empty thread_id current; state_index = 2 } (* * Debugging. *) let print_thread_id out = Format.fprintf out "%d" (Lm_thread_core.ThreadCore.id (Lm_thread_core.ThreadCore.self ())) (* * Perform something with the state lock. *) let with_lock debug f x = if !debug_lock then Format.eprintf "\tLocking: %t: %s@." print_thread_id debug; Mutex.lock state.state_lock; try let result = f x in Mutex.unlock state.state_lock; if !debug_lock then Format.eprintf "\tUnlocking: %t: %s@." print_thread_id debug; result with exn -> Mutex.unlock state.state_lock; if !debug_lock then Format.eprintf "Unlocking: %t: %s (exception)@." print_thread_id debug; raise exn (* * Release the lock temporarily. *) let with_unlock debug f x = if !debug_lock then Format.eprintf "\tUnlocking temporarily: %t: %s@." print_thread_id debug; Mutex.unlock state.state_lock; try let result = f x in Mutex.lock state.state_lock; if !debug_lock then Format.eprintf "\tRelocking: %t: %s@." print_thread_id debug; result with exn -> Mutex.lock state.state_lock; if !debug_lock then Format.eprintf "Relocking: %t: %s (exception)@." print_thread_id debug; raise exn (* * Create a new thread. Assign a new thread struct. * The thread uses the same state as its parent. *) let create_thread f x = let parent = Lm_thread_core.ThreadCore.id (Lm_thread_core.ThreadCore.self ()) in let pthread = try Lm_int_set.IntTable.find state.state_threads parent with Not_found -> raise (Invalid_argument "Thread.create: current thread is unknown") in let start () = let id = Lm_thread_core.ThreadCore.id (Lm_thread_core.ThreadCore.self ()) in let cleanup () = with_lock "create_thread.cleanup" (fun () -> state.state_threads <- Lm_int_set.IntTable.remove state.state_threads id) () in (* Set up the new state *) with_lock "create_thread.start" (fun () -> let thread = { thread_id = id; thread_parent = parent; thread_cond = Condition.create (); thread_state = pthread.thread_state } in state.state_threads <- Lm_int_set.IntTable.add state.state_threads id thread) (); (* Run the function, and clean up afterwards *) try f x; cleanup () with exn -> Format.eprintf "Uncaught thread exception: %s@." (Printexc.to_string exn); cleanup () in let child = Lm_thread_core.ThreadCore.create start () in if !debug_lock then Format.eprintf "Started child %i from thread %t@." (Lm_thread_core.ThreadCore.id child) print_thread_id; child (* * Get the thread info for the current thread. * Every thread must have some info. *) let get_thread_info () = let tid = Lm_thread_core.ThreadCore.id (Lm_thread_core.ThreadCore.self ()) in try Lm_int_set.IntTable.find state.state_threads tid with Not_found -> raise (Invalid_argument "Lm_thread.get_thread_info: unknown thread") let get_parent_info thread = try Lm_int_set.IntTable.find state.state_threads thread.thread_parent with Not_found -> raise (Invalid_argument "Lm_thread.get_thread_info: unknown parent thread") (* * Create a new state identifier. *) let create_state () = with_lock "create_state" (fun () -> let index = state.state_index in state.state_index <- succ index; index) () (* * Get the current state identifier. *) let current_state () = let thread = get_thread_info () in thread.thread_state (* * Set the state for the current thread. *) let set_state id = let thread = get_thread_info () in thread.thread_state <- id (* * Use the specified state for the current thread. *) let with_state id f x = let thread = get_thread_info () in let oid = thread.thread_state in try thread.thread_state <- id; let result = f x in thread.thread_state <- oid; result with exn -> thread.thread_state <- oid; raise exn (* * Once a thread finishes, unlock the remaining processes. * We assume a lock. *) let release handle = let len = Queue.length handle.handle_queue in if len <> 0 then match Queue.take handle.handle_queue with RequestRead thread -> Condition.signal thread.thread_cond; let rec unblock i = if i <> 0 then let info = Queue.peek handle.handle_queue in match info with RequestRead thread -> ignore (Queue.take handle.handle_queue); Condition.signal thread.thread_cond; unblock (pred i) | RequestWrite _ -> () in unblock (pred len) | RequestWrite thread -> Condition.signal thread.thread_cond (* * Get the lock record. * We assume the state is locked. * Just in case, check the lock. *) let rec fork_handle thread info = let state_id = thread.thread_state in try Lm_int_set.IntTable.find info.info_entries state_id with Not_found -> if !debug_lock then Format.eprintf "Forking handle: %s: state=%d parent=%d this=%d@." (**) info.info_debug state_id thread.thread_parent thread.thread_id; (* Prevent recursion *) let () = info.info_forks <- Lm_int_set.IntSet.add info.info_forks state_id in (* Get the new value *) let handle_value = if state_id = 1 then info.info_default else if thread.thread_parent = thread.thread_id then with_unlock "fork_handle" info.info_fork info.info_default else let parent = get_parent_info thread in let parent_handle = fork_handle parent info in with_unlock "fork_handle" info.info_fork parent_handle.handle_value in (* Call the fork function *) let handle = { handle_value = handle_value; handle_debug = Printf.sprintf "%s[%d]" info.info_debug state_id; handle_state = HandleUnlocked; handle_queue = Queue.create (); handle_readers = 0; handle_writers = 0; handle_active = Lm_int_set.IntTable.empty } in if !debug_lock then Format.eprintf "Forked handle: %s: state=%d parent=%d this=%d@." (**) handle.handle_debug state_id thread.thread_parent thread.thread_id; info.info_entries <- Lm_int_set.IntTable.add info.info_entries state_id handle; info.info_forks <- Lm_int_set.IntSet.remove info.info_forks state_id; fork_handle thread info let handle_of_info thread info = with_lock "handle_of_info" (fork_handle thread) info let get_handle thread entry = let handle = match entry with EntryShared handle -> handle | EntryPrivate info -> handle_of_info thread info in if !debug_lock then Format.eprintf "get_handle: %s@." handle.handle_debug; handle (* * Reader operations. *) let read_lock thread handle = with_lock "read_lock" (fun () -> if handle.handle_writers <> 0 then begin if !debug_lock then Format.eprintf "read_lock: %t: %s: waiting@." print_thread_id handle.handle_debug; Queue.add (RequestRead thread) handle.handle_queue; Condition.wait thread.thread_cond state.state_lock end; handle.handle_state <- HandleReading; handle.handle_readers <- succ handle.handle_readers; handle.handle_active <- Lm_int_set.IntTable.add handle.handle_active thread.thread_id ModeReading) () let read_unlock thread handle = with_lock "read_unlock" (fun () -> let count = pred handle.handle_readers in handle.handle_readers <- count; handle.handle_active <- Lm_int_set.IntTable.remove handle.handle_active thread.thread_id; if count = 0 then begin handle.handle_state <- HandleUnlocked; release handle end) () (* * Perform a read. * If we already have a read lock, just run the function. *) let read_wrap thread handle f = read_lock thread handle; try let x = f handle.handle_value in read_unlock thread handle; x with exn -> read_unlock thread handle; raise exn let read_thread_handle thread handle f = if Lm_int_set.IntTable.mem handle.handle_active thread.thread_id then f handle.handle_value else read_wrap thread handle f let read entry f = if !debug_lock then Format.eprintf "Read: %t: enter@." print_thread_id; let thread = get_thread_info () in let handle = get_handle thread entry in let x = read_thread_handle thread handle f in if !debug_lock then Format.eprintf "Read: %t: %s: end@." print_thread_id handle.handle_debug; x (* * Writer operations. *) let write_lock thread handle = if !debug_lock then Format.eprintf "write_lock: %t: begin@." print_thread_id; with_lock "write_lock" (fun () -> handle.handle_writers <- succ handle.handle_writers; if handle.handle_state <> HandleUnlocked then begin if !debug_lock then Format.eprintf "write_lock: %t: waiting@." print_thread_id; Queue.add (RequestWrite thread) handle.handle_queue; Condition.wait thread.thread_cond state.state_lock end; handle.handle_state <- HandleWriting; handle.handle_active <- Lm_int_set.IntTable.add handle.handle_active thread.thread_id ModeWriting) () let write_unlock thread handle = if !debug_lock then Format.eprintf "write_unlock: %t: begin@." print_thread_id; with_lock "write_unlock" (fun () -> handle.handle_state <- HandleUnlocked; handle.handle_writers <- pred handle.handle_writers; handle.handle_active <- Lm_int_set.IntTable.remove handle.handle_active thread.thread_id; release handle) () let write_wrap thread handle f = if !debug_lock then Format.eprintf "write_wrap: %t: begin@." print_thread_id; write_lock thread handle; try let x = f handle.handle_value in write_unlock thread handle; x with exn -> if !debug_lock then Format.eprintf "write_wrap: %t: exception@." print_thread_id; write_unlock thread handle; raise exn let write_thread_handle thread handle f = let locked = try match Lm_int_set.IntTable.find handle.handle_active thread.thread_id with ModeReading -> raise (Invalid_argument "State.write: handle already has a read lock") | ModeWriting -> true with Not_found -> false in if locked then if !debug_lock then begin Format.eprintf "write_thread_handle: %t: begin: already locked@." print_thread_id; try let x = f handle.handle_value in Format.eprintf "write_thread_handle: %t: end: already locked@." print_thread_id; x with exn -> Format.eprintf "write_thread_handle: %t: end: already locked (exception)@." print_thread_id; raise exn end else f handle.handle_value else write_wrap thread handle f let write entry f = if !debug_lock then Format.eprintf "Write: %t: enter@." print_thread_id; let thread = get_thread_info () in let handle = get_handle thread entry in if !debug_lock then Format.eprintf "Writing begin: %t: %s: writers = %d@." print_thread_id handle.handle_debug handle.handle_writers; let x = write_thread_handle thread handle f in if !debug_lock then Format.eprintf "Writing end: %t: %s: writers = %d@." print_thread_id handle.handle_debug handle.handle_writers; x (* * Unlock temporarily. *) let unlock_unlock thread handle = let mode = try Lm_int_set.IntTable.find handle.handle_active thread.thread_id with Not_found -> raise (Invalid_argument "State.unlock: thread does not have a lock") in let () = match mode with ModeReading -> read_unlock thread handle | ModeWriting -> write_unlock thread handle in mode let unlock_lock thread handle mode = match mode with ModeReading -> read_lock thread handle | ModeWriting -> write_lock thread handle (* * Unlock function. *) let unlock_thread_handle thread handle f = let mode = unlock_unlock thread handle in try let x = f () in unlock_lock thread handle mode; x with exn -> unlock_lock thread handle mode; raise exn let unlock entry f = if !debug_lock then Format.eprintf "Unlock: %t: begin@." print_thread_id; let thread = get_thread_info () in let handle = get_handle thread entry in let x = unlock_thread_handle thread handle f in if !debug_lock then Format.eprintf "Unlock: %t: %s: end@." print_thread_id handle.handle_debug; x (* * Get the value. * Verify that this thread has a lock on the object. *) let get_thread_handle thread handle = if Lm_int_set.IntTable.mem handle.handle_active thread.thread_id then handle.handle_value else raise (Invalid_argument (Printf.sprintf "State.get: %s: entry is not locked" handle.handle_debug)) let get entry = if !debug_lock then Format.eprintf "Get: %t: begin@." print_thread_id; let thread = get_thread_info () in let handle = get_handle thread entry in let x = get_thread_handle thread handle in if !debug_lock then Format.eprintf "Get: %t: %s: end@." print_thread_id handle.handle_debug; x (* * Create a shared value. *) let shared_val debug x = let handle = { handle_value = x; handle_debug = debug; handle_state = HandleUnlocked; handle_queue = Queue.create (); handle_readers = 0; handle_writers = 0; handle_active = Lm_int_set.IntTable.empty } in EntryShared handle (* * Create a private value. * This means that each state has its own copy of the * data. *) let private_val debug x fork = let info = { info_default = x; info_debug = debug; info_fork = fork; info_forks = Lm_int_set.IntSet.empty; info_entries = Lm_int_set.IntTable.empty } in EntryPrivate info (* * Thread implementation. *) module Thread = struct type t = Lm_thread_core.ThreadCore.t type id = int let enabled = Lm_thread_core.ThreadCore.enabled let create = create_thread let self = Lm_thread_core.ThreadCore.self let join = Lm_thread_core.ThreadCore.join let id = Lm_thread_core.ThreadCore.id let sigmask = Lm_thread_core.ThreadCore.sigmask let raise_ctrl_c_wrapper = Lm_thread_core.ThreadCore.raise_ctrl_c_wrapper end (* * States are identified by integers. *) module State = struct type t = state_id (* Silly redefinition to break type recursion *) type 'a local_entry = 'a entry type 'a entry = 'a local_entry (* * State operations. *) let current = current_state let create = create_state let set = set_state let with_state = with_state (* * Variables. *) let shared_val = shared_val let private_val = private_val let read = read let write = write let unlock = unlock let get = get end (* * We need to work nicely with threads. * * Note that the reintern function may be recursive, so we need to account for cases, * where the current thread is already holding the lock. * Almost every accesses come from the main thread with very little if any contention from other * threads. This makes it more effiecient to use a single global lock (as opposed to having a * separate lock for each instance of the functor), so that mutually recursive reintern calls only * have to lock one lock, not all of them. * * Finally, we do not care about race conditions for the statistics *) module Synchronize : sig val synchronize : ('a -> 'b) -> 'a -> 'b end = struct let lock_mutex = Mutex.create "Lm_hash.Synchronize" let lock_id = ref None let unsynchronize () = lock_id := None; Mutex.unlock lock_mutex let synchronize f x = let id = Thread.id (Thread.self ()) in match !lock_id with Some id' when id = id' -> (* * We are already holding the lock. This means: * - we do not have to do anything special * - reading the shared lock_id ref could not have created a race condition *) f x | _ -> Mutex.lock lock_mutex; lock_id := Some id; try let res = f x in unsynchronize(); res with exn -> unsynchronize(); raise exn let synchronize = if Thread.enabled then synchronize else (fun f -> f) end omake-0.10.3/src/libmojave/lm_notify.ml0000644000175000017500000002212213177364665016425 0ustar gerdgerdlet debug_notify = Lm_debug.create_debug { debug_name = "notify"; debug_description = "Print the information on FAM events."; debug_value = false } (* * Tables. *) module IntCompare = struct type t = int let compare (x : int) (y : int) = Pervasives.compare x y end module StringCompare = struct type t = string let compare (x : string) (y : string) = Pervasives.compare x y end module IntTable = Lm_map.LmMake (IntCompare) module StringTable = Lm_map.LmMake (StringCompare) (* * The state of the notifier. *) type request = int type job = { dir : string; path : Lm_filename_util.root * string list; recursive : bool; request : request; mutable running : bool } type code = Changed | Deleted | StartExecuting | StopExecuting | Created | Moved | Acknowledge | Exists | EndExist | DirectoryChanged type notify_event = { ne_request : request; ne_name : string; ne_code : code } type event = { notify_code : code; notify_name : string } type info type t = { notify_info : info; notify_fd : Unix.file_descr option; mutable notify_dirs : request StringTable.t; mutable notify_requests : job IntTable.t } (* * C stubs. *) external notify_enabled : unit -> bool = "om_notify_enabled" external notify_open : unit -> info = "om_notify_open" external notify_close : info -> unit = "om_notify_close" external notify_fd : info -> Unix.file_descr = "om_notify_fd" external notify_monitor_directory : info -> string -> bool -> request = "om_notify_monitor_directory" external notify_suspend : info -> request -> unit = "om_notify_suspend" external notify_resume : info -> request -> unit = "om_notify_resume" external notify_cancel : info -> request -> unit = "om_notify_cancel" external notify_pending : info -> bool = "om_notify_pending" external notify_next_event : info -> notify_event = "om_notify_next_event";; (************************************************************************ * Utilities *) (* * Canonical name for a directory. *) let name_of_dir dir = Lm_filename_util.normalize_string dir let path_of_name name = match Lm_filename_util.filename_path name with Lm_filename_util.AbsolutePath (root, path) -> root, path | Lm_filename_util.RelativePath _ -> raise (Invalid_argument ("Lm_notify.path_of_name: " ^ name ^ ": all paths must be absolute")) (* * Check if a filename is part of a directory tree. *) let is_path_prefix (root1, path1) (root2, path2) = let rec is_prefix l1 l2 = match l1, l2 with h1 :: l1, h2 :: l2 -> h1 = h2 && is_prefix l1 l2 | [], _ -> true | _, [] -> false in root1 = root2 && is_prefix path1 path2 let is_monitored_name requests name = let new_path = path_of_name name in IntTable.exists (fun _ job -> let { path = path; recursive = recursive; _ } = job in new_path = path || (recursive && is_path_prefix path new_path)) requests (************************************************************************ * Notify API. *) (* * Debugging. *) let string_of_code code = match code with | Changed -> "Changed" | Deleted -> "Deleted" | StartExecuting -> "StartExecuting" | StopExecuting -> "StopExecuting" | Created -> "Created" | Moved -> "Moved" | Acknowledge -> "Acknowledge" | Exists -> "Exists" | EndExist -> "EndExists" | DirectoryChanged -> "DirectoryChanged" (* * Is this enabled? *) let enabled = notify_enabled () (* * Open a connection. *) let create () = let info = notify_open () in let fd = try let fd = notify_fd info in if !debug_notify then Format.eprintf "Lm_notify.create: fd = %i@." (Lm_unix_util.int_of_fd fd); Some fd with Failure _ -> if !debug_notify then Format.eprintf "Lm_notify.create: no fd @."; None in { notify_info = info; notify_fd = fd; notify_dirs = StringTable.empty; notify_requests = IntTable.empty } (* * Close the connection. *) let close notify = notify_close notify.notify_info (* * Get the file descriptor. *) let file_descr { notify_fd = fd ; _} = fd (* * Monitoring. *) let monitor notify dir recursive = let { notify_info = info; notify_dirs = dirs; notify_requests = requests; _ } = notify in let name = name_of_dir dir in if not (is_monitored_name requests name) then begin if !debug_notify then Format.eprintf "Lm_notify.monitor: %s, recursive: %b@." name recursive; let request = notify_monitor_directory info dir recursive in let job = { dir = dir; path = path_of_name name; recursive = recursive; running = true; request = request } in let dirs = StringTable.add dirs name request in let requests = IntTable.add requests request job in notify.notify_dirs <- dirs; notify.notify_requests <- requests end (* * Suspend notifications. *) let suspend notify dir = let { notify_info = info; notify_dirs = dirs; notify_requests = requests; _ } = notify in let dir = name_of_dir dir in let request = try StringTable.find dirs dir with Not_found -> raise (Invalid_argument "suspend_dir") in let job = IntTable.find requests request in if job.running then begin notify_suspend info job.request; job.running <- false end let suspend_all notify = let { notify_info = info; notify_requests = requests; _ } = notify in IntTable.iter (fun _ job -> if job.running then begin notify_suspend info job.request; job.running <- false end) requests let resume notify dir = let { notify_info = info; notify_dirs = dirs; notify_requests = requests; _ } = notify in let dir = name_of_dir dir in let request = try StringTable.find dirs dir with Not_found -> raise (Invalid_argument "resume_dir") in let job = IntTable.find requests request in if not job.running then begin notify_resume info job.request; job.running <- true end let resume_all notify = let { notify_info = info; notify_requests = requests; _ } = notify in IntTable.iter (fun _ job -> if not job.running then begin notify_resume info job.request; job.running <- true end) requests (* * Cancel a request. *) let cancel notify dir = let { notify_info = info; notify_dirs = dirs; notify_requests = requests; _ } = notify in let dir = name_of_dir dir in let request = try StringTable.find dirs dir with Not_found -> raise (Invalid_argument "cancel_dir") in let job = IntTable.find requests request in notify_cancel info job.request; notify.notify_dirs <- StringTable.remove dirs dir; notify.notify_requests <- IntTable.remove requests request let cancel_all notify = let { notify_info = info; notify_requests = requests; _ } = notify in IntTable.iter (fun request _ -> notify_cancel info request) requests; notify.notify_dirs <- StringTable.empty; notify.notify_requests <- IntTable.empty (* * Check for a pending event. *) let pending notify = let pending = notify_pending notify.notify_info in if !debug_notify then Format.eprintf "Lm_notify.pending: %s@." (if pending then "true" else "false"); pending (* * Get the next event. *) let next_event notify = if !debug_notify then Format.eprintf "Lm_notify.next_event: starting@."; let { ne_request = request; ne_name = name; ne_code = code } = notify_next_event notify.notify_info in if !debug_notify then Format.eprintf "Lm_notify.next_event: received event for name %s, code %s@." name (string_of_code code); let job = try IntTable.find notify.notify_requests request with Not_found -> raise (Invalid_argument "Lm_notify.next_event: unknown request") in let filename = if Filename.is_relative name then Filename.concat job.dir name else name in if !debug_notify then Format.eprintf "Lm_notify.next_event: filename is %s@." filename; { notify_code = code; notify_name = filename } omake-0.10.3/src/libmojave/lm_symbol.ml0000644000175000017500000001364013177364665016427 0ustar gerdgerd(* * Right now the symbol table is just a representation of strings. *) let debug_symbol = ref false (* * Hash-cons the symbols. *) (* %%MAGICBEGIN%% *) module SymbolHashArg = struct type t = int * string let debug = "Symbol" let hash = Hashtbl.hash let compare (i1, s1) (i2, s2) = if i1 < i2 then -1 else if i1 > i2 then 1 else Lm_string_util.string_compare s1 s2 let reintern s = s end;; module SymbolHash = Lm_hash.MakeCoarse (SymbolHashArg);; type t = SymbolHash.t (* %%MAGICEND%% *) (* * We no longer use a hashtable. * Symbols with a 0 index are interned. *) let eq = SymbolHash.equal let compare = SymbolHash.compare let hash = SymbolHash.hash (* An "empty" variable name *) let empty_var = SymbolHash.create (0, "") let new_number, make = let count = ref 100 in let lock = Lm_thread.Mutex.create "Lm_symbol_hash" in (fun () -> Lm_thread.Mutex.lock lock; let i = !count in count := succ i; Lm_thread.Mutex.unlock lock; i), (fun s i -> if i >= !count then begin Lm_thread.Mutex.lock lock; count := max (!count) (i + 1); Lm_thread.Mutex.unlock lock end; SymbolHash.create (i, s)) (* * Create a new symbol. * Don't add it to the table. *) let new_symbol_string s = SymbolHash.create (new_number (), s) (* * Get the integer prefix. *) let to_int v = fst (SymbolHash.get v) (* * Get the string suffix. *) let to_string v = snd (SymbolHash.get v) let char0 = Char.code '0' let rec zeros s i = (i < 0) || match s.[i] with | '1'..'9' -> false | '0' -> zeros s (i - 1) | _ -> true let rec all_digits s i = (i<0) || match s.[i] with | '0' .. '9' -> all_digits s (i - 1) | _ -> false let rec pad_with_underscore n s i : bool = if i <= 0 then n > 0 else let i = i - 1 in match s.[i] with | '_' -> pad_with_underscore n s i | '0' -> not (zeros s (i - 1)) && ((n>0) || not (all_digits s (i - 1))) | '1' .. '9' -> (n>0) || not (all_digits s (i - 1)) | _ -> false let rec loop s fact n i : t = if i < 0 then SymbolHash.create (0, s) else match s.[i] with '_' -> make (String.sub s 0 (if pad_with_underscore n s i then i else i + 1)) n | '0' when zeros s (i - 1) -> make (String.sub s 0 (succ i)) n | '0'..'9' as c -> loop s (fact * 10) (n + fact * (Char.code c - char0)) (i - 1) | _ -> make (String.sub s 0 (i + 1)) n let add s = loop s 1 0 (String.length s - 1) let is_numeric_symbol v = match SymbolHash.get v with | (0, s) -> all_digits s (String.length s - 1) | _ -> false let new_symbol v = new_symbol_string (to_string v) let new_symbol_pre pre v = let v = to_string v in let s = if Lm_debug.debug debug_symbol then v ^ "/" ^ pre else v in new_symbol_string s (* * Create a new symbol, avoiding the ones defined by the predicate. *) let new_name v pred = let v = to_string v in let rec search i = let nv = make v i in if pred nv then search (succ i) else nv in search 0 (* * Create a new symbol, calling the function f until it * returns non-nil. *) let new_name_gen v f = let v = to_string v in let rec search i = let nv = make v i in match f nv with | Some x -> x | None -> search (i + 1) in search 0 (* * Check if the symbol is in the table. *) let is_interned v = to_int v = 0 let dump_symbol fmt v = let i, s = SymbolHash.get v in Format.fprintf fmt "(%d,%s)" i s exception Has;; (* * Printer. * If the symbol is not a defined symbol, * print the index. *) let string_of_symbol v = let i, s = SymbolHash.get v in let len = String.length s in let s = if pad_with_underscore i s len then s ^ "_" else s in if i = 0 then s else s ^ string_of_int i let string_of_ext_symbol v = let i, s = SymbolHash.get v in let has_special_char s = try for i = 0 to String.length s - 1 do let c = Char.lowercase_ascii (String.get s i) in if not ((Char.code c >= Char.code 'a' && Char.code c <= Char.code 'z') || (Char.code c >= Char.code '0' && Char.code c <= Char.code '9') || c = '_') then raise Has done; false with Has -> true in let s = if i = 0 then s else Lm_printf.sprintf "%s%d" s i in if has_special_char s then Lm_printf.sprintf "`\"%s\"" s else s let pp_print_ext_symbol buf v = Lm_printf.pp_print_string buf (string_of_ext_symbol v) let pp_print_symbol buf v = Lm_printf.pp_print_string buf (string_of_symbol v) let output_symbol out v = Lm_printf.pp_print_string out (string_of_symbol v) let rec output_symbol_list out vl = match vl with [v] -> output_symbol out v | v :: vl -> Format.fprintf out "%a, %a" output_symbol v output_symbol_list vl | [] -> () let rec pp_print_symbol_list buf vl = match vl with [v] -> pp_print_symbol buf v | v :: vl -> Format.fprintf buf "%a, %a" pp_print_symbol v pp_print_symbol_list vl | [] -> () (* * Method name. *) let rec pp_print_method_name buf vl = match vl with |[v] -> pp_print_symbol buf v | v :: vl -> Format.fprintf buf "%a.%a" pp_print_symbol v pp_print_method_name vl | [] -> () (* * Build sets, tables, indices where the keys are symbols, * ordered symbol pairs, or orderd symbol triples. *) module Base = struct type t = SymbolHash.t let compare = compare end module SymbolSet = Lm_set.LmMake (Base) module SymbolTable = Lm_map.LmMake (Base) module SymbolMTable = Lm_map.LmMakeList (Base) module SymbolIndex = Lm_index.LmMake (Base) (* * Symbol lists are also useful. *) let output_symbol_set out s = output_symbol_list out (SymbolSet.to_list s) let pp_print_symbol_set buf s = pp_print_symbol_list buf (SymbolSet.to_list s) omake-0.10.3/src/libmojave/lm_bitset.ml0000644000175000017500000000246513177364665016417 0ustar gerdgerdtype t = int array let bits_per_int = if Sys.word_size = 64 then 62 else 30 let create() = [| 0 |] let is_set bitset b = b >= 0 && ( let j = b / bits_per_int in j < Array.length bitset && ( let k = b mod bits_per_int in let x = bitset.(j) in ((x lsr k) land 1) <> 0 ) ) let set bitset b = if b < 0 then invalid_arg "Lm_bitset.set"; let j = b / bits_per_int in let bitset' = if j < Array.length bitset then Array.copy bitset else let bitset' = Array.make (j+1) 0 in Array.blit bitset 0 bitset' 0 (Array.length bitset); bitset' in let k = b mod bits_per_int in let x = bitset'.(j) in let x' = x lor (1 lsl k) in bitset'.(j) <- x'; bitset' let set_multiple bitset b_list = let m = List.fold_left ( max ) 0 b_list in let mj = m / bits_per_int in let bitset' = if mj < Array.length bitset then Array.copy bitset else let bitset' = Array.make (mj+1) 0 in Array.blit bitset 0 bitset' 0 (Array.length bitset); bitset' in List.iter (fun b -> if b < 0 then invalid_arg "Lm_bitset.set_multiple"; let j = b / bits_per_int in let k = b mod bits_per_int in let x = bitset'.(j) in let x' = x lor (1 lsl k) in bitset'.(j) <- x'; ) b_list; bitset' omake-0.10.3/src/libmojave/lm_printf.ml0000644000175000017500000000325313177364665016423 0ustar gerdgerd include Format type 'a t = Format.formatter -> 'a -> unit (** * Redirect formatter's output to both a channel and a log file. * The log file will be appended (not truncated), lockf-mutexed, * and all the entries will be annotated with the PID of the logger: * [|PID1: string1|][|PID2: string2|]... * (with consequetive non-NL strings from the same PID merged together). *) let open_out name = formatter_of_out_channel (open_out name) let open_out_bin name = formatter_of_out_channel (open_out_bin name) (** Normal printing.*) let print_char = pp_print_char std_formatter let print_int = pp_print_int std_formatter let print_string = pp_print_string std_formatter let prerr_char = pp_print_char err_formatter let prerr_int = pp_print_int err_formatter let prerr_string = pp_print_string err_formatter (** Print a newline and flush. *) let flush buf = pp_print_flush buf () let eflush buf = pp_print_newline buf () let byte_formatter out flush = make_formatter (fun s pos len -> out (Bytes.of_string (String.sub s pos len)) 0 len) flush (* * List separated by semicolons. *) let rec print_any_list print out l = match l with | [h] -> print out h | h::t -> print out h; pp_print_string out "; "; print_any_list print out t | [] -> () let print_string_list = print_any_list pp_print_string let print_int_list = print_any_list pp_print_int (* Get a formatter. *) let out_channel_of_formatter out = out let rec pp_print_any_list print buf = function | [] -> () | [a] -> print buf a | a::rest -> print buf a; pp_print_string buf ";"; pp_print_space buf (); pp_print_any_list print buf rest omake-0.10.3/src/libmojave/lm_marshal.ml0000644000175000017500000002641013177364665016550 0ustar gerdgerd(* * A generic marshaler. * For marshaling, we need a *) (* * All items eventually become ints, floats, or strings. *) type 'a item = | Bool of bool | Char of char | Code of int | Symbol of int | Int of int | Magic of 'a | Float of float | String of string | List of 'a item list (************************************************************************ * MARSHALING ************************************************************************) (* * IO module. *) module type MarshalIOSig = sig type t type in_channel type out_channel (* Convert between magic ids *) val magic_of_int : int -> t val int_of_magic : t -> int (* IO *) val input_byte : in_channel -> int val input_buffer : in_channel -> bytes -> int -> int -> unit val output_byte : out_channel -> int -> unit val output_buffer : out_channel -> bytes -> int -> int -> unit end (* Marshal module. *) module type MarshalSig = sig type t type in_channel type out_channel val marshal : out_channel -> t item -> unit val unmarshal : in_channel -> t item end (* * Output routines. *) module Make (IO : MarshalIOSig) : MarshalSig with type t = IO.t with type in_channel = IO.in_channel with type out_channel = IO.out_channel = struct type t = IO.t type in_channel = IO.in_channel type out_channel = IO.out_channel (* Codes. *) let true_magic = 0xe0 let false_magic = 0xe1 let char_magic = 0xe2 let code_magic = 0xe3 let symbol_magic = 0xe4 let int_magic = 0xe5 let magic_magic = 0xe6 let float_magic = 0xe8 let string_magic = 0xea let list_magic = 0xeb let version_number = Hashtbl.hash "$Id$" (************************************************************************ * BASIC IO ************************************************************************) (* * Basic routines. *) let output_byte out i = IO.output_byte out (i land 0xff) let input_byte inc = IO.input_byte inc let output_char out c = output_byte out (Char.code c) let input_char inc = Char.chr (input_byte inc) let output_int out i = output_byte out ((i lsr 24) land 0xff); output_byte out ((i lsr 16) land 0xff); output_byte out ((i lsr 8) land 0xff); output_byte out (i land 0xff) let input_int inc = let i = input_byte inc in let i = (i lsl 8) lor (input_byte inc) in let i = (i lsl 8) lor (input_byte inc) in let i = (i lsl 8) lor (input_byte inc) in i let output_int16 out i = output_byte out ((i lsr 8) land 0xff); output_byte out (i land 0xff) let input_int16 inc = let i1 = input_byte inc in let i2 = input_byte inc in (i1 lsl 8) lor i2 let output_int64 out i = output_byte out ((Int64.to_int (Int64.shift_right i 56)) land 0xff); output_byte out ((Int64.to_int (Int64.shift_right i 48)) land 0xff); output_byte out ((Int64.to_int (Int64.shift_right i 40)) land 0xff); output_byte out ((Int64.to_int (Int64.shift_right i 32)) land 0xff); output_byte out ((Int64.to_int (Int64.shift_right i 24)) land 0xff); output_byte out ((Int64.to_int (Int64.shift_right i 16)) land 0xff); output_byte out ((Int64.to_int (Int64.shift_right i 8)) land 0xff); output_byte out ((Int64.to_int i) land 0xff) let input_int64 inc = let i = Int64.shift_left (Int64.of_int (input_byte inc)) 56 in let i = Int64.logor i (Int64.shift_left (Int64.of_int (input_byte inc)) 48) in let i = Int64.logor i (Int64.shift_left (Int64.of_int (input_byte inc)) 40) in let i = Int64.logor i (Int64.shift_left (Int64.of_int (input_byte inc)) 32) in let i = Int64.logor i (Int64.shift_left (Int64.of_int (input_byte inc)) 24) in let i = Int64.logor i (Int64.shift_left (Int64.of_int (input_byte inc)) 16) in let i = Int64.logor i (Int64.shift_left (Int64.of_int (input_byte inc)) 8) in let i = Int64.logor i (Int64.of_int (input_byte inc)) in i (* * Floats. *) let output_float out x = output_int64 out (Int64.bits_of_float x) let input_float inc = Int64.float_of_bits (input_int64 inc) (* * Meta. *) let output_magic = output_byte let input_magic = input_byte let output_size out i = if i >= 0 && i < 255 then output_byte out i else begin output_byte out 255; output_int out i end let input_size inc = let i = input_byte inc in if i < 255 then i else input_int inc (************************************************************************ * MARSHALING ************************************************************************) (* * Marshal base types. *) let marshal_bool out b = (* eprintf "Bool: %b%t" b eflush; *) if b then output_magic out true_magic else output_magic out false_magic let marshal_char out c = output_magic out char_magic; output_char out c let marshal_code out i = (* eprintf "Int: %d%t" i eflush; *) output_magic out code_magic; output_int16 out i let marshal_symbol out i = (* eprintf "Int: %d%t" i eflush; *) output_magic out symbol_magic; output_int16 out i let marshal_int out i = (* eprintf "Int: %d%t" i eflush; *) output_magic out int_magic; output_int out i let marshal_magic out x = let index = IO.int_of_magic x in (* eprintf "Magic: %d%t" index eflush; *) output_magic out magic_magic; output_int out index let marshal_float out x = (* eprintf "Float: %g%t" x eflush; *) output_magic out float_magic; output_float out x let marshal_string out s = let len = String.length s in (* eprintf "String: %s%t" s eflush; *) output_magic out string_magic; output_size out len; IO.output_buffer out (Bytes.of_string s) 0 len (* * Marshaler *) let rec marshal_item out x = match x with Bool b -> marshal_bool out b | Char c -> marshal_char out c | Code i -> marshal_code out i | Symbol i -> marshal_symbol out i | Int i -> marshal_int out i | Magic i -> marshal_magic out i | Float x -> marshal_float out x | String s -> marshal_string out s | List l -> marshal_list out l and marshal_list out l = let len = List.length l in (* eprintf "List: %d%t" len eflush; *) output_magic out list_magic; output_size out len; List.iter (marshal_item out) l (* * Save the version number. *) let marshal_version out = output_int out version_number (* * First collect strings and save them. *) let marshal out l = marshal_version out; marshal_item out l (************************************************************************ * UNMARSHALING ************************************************************************) (* * Reading. *) let unmarshal_bool b = (* eprintf "Bool: %b%t" b eflush; *) Bool b let unmarshal_magic inc = let i = input_int inc in (* eprintf "Magic: %d%t" i eflush; *) Magic (IO.magic_of_int i) let unmarshal_char inc = let c = input_char inc in (* eprintf "Char: %c%t" c eflush; *) Char c let unmarshal_code inc = let i = input_int16 inc in (* eprintf "Int: %d%t" i eflush; *) Code i let unmarshal_symbol inc = let i = input_int16 inc in (* eprintf "Int: %d%t" i eflush; *) Symbol i let unmarshal_int inc = let i = input_int inc in (* eprintf "Int: %d%t" i eflush; *) Int i let unmarshal_float inc = let x = input_float inc in (* eprintf "Float: %g%t" x eflush; *) Float x let unmarshal_string inc = let len = input_size inc in let _ = if len < 0 then raise (Failure "unmarshal_string: string length is negative") in let s = Bytes.create len in IO.input_buffer inc s 0 len; (* eprintf "String: %s%t" s eflush; *) String (Bytes.to_string s) (* * Build a value from the input. *) let rec unmarshal_item inc = let magic = input_magic inc in if magic = true_magic then unmarshal_bool true else if magic = false_magic then unmarshal_bool false else if magic = char_magic then unmarshal_char inc else if magic = code_magic then unmarshal_code inc else if magic = symbol_magic then unmarshal_symbol inc else if magic = int_magic then unmarshal_int inc else if magic = magic_magic then unmarshal_magic inc else if magic = float_magic then unmarshal_float inc else if magic = string_magic then unmarshal_string inc else if magic = list_magic then unmarshal_list inc else raise (Failure (Lm_printf.sprintf "unmarshal: unexpected magic number 0x%02x" magic)) and unmarshal_list inc = let len = input_size inc in (* let _ = eprintf "List: %d%t" len eflush in *) let rec collect i l = if i = 0 then List (List.rev l) else let x = unmarshal_item inc in collect (pred i) (x :: l) in collect len [] (* * Read the version number. *) let unmarshal_version inc = let i = input_int inc in if i <> version_number then raise (Failure (Lm_printf.sprintf "unmarshal_version: bogus version number: 0x%08x, should be 0x%08x" i version_number)) (* Now read the data. *) let unmarshal inc = unmarshal_version inc; unmarshal_item inc end (* * Marshaling of messages. *) type magic = | LocationMagic | IdMagic | NullRootMagic | DriveRootMagic | DirRootMagic | DirSubMagic | NodeFileMagic | NodePhonyGlobalMagic | NodePhonyDirMagic | NodePhonyFileMagic | NodeFlaggedMagic | NodeIsOptionalMagic | NodeIsExistingMagic | NodeIsSquashedMagic | NodeIsScannerMagic | QuietFlagMagic | AllowFailureFlagMagic | AllowOutputFlagMagic | CommandLineMagic | PrintEagerMagic | PrintLazyMagic | PrintExitMagic | RequestSpawnMagic | ResponseCreateMagic | ResponseExitedMagic | ResponseStdoutMagic | ResponseStderrMagic | MaxMagic | ResponseStatusMagic type msg = magic item exception MarshalError (* * Some common marshalers. *) let marshal_string_list l : 'a item = List (List.map (fun s -> (String s : 'a item)) l) let unmarshal_string_list (l : 'a item) : string list = match l with | List l -> List.map (function | (String s : 'a item) -> s | _ -> raise MarshalError) l | _ -> raise MarshalError let marshal_loc (loc : Lm_location.t) : msg = let file, sline, schar, eline, echar = Lm_location.dest_loc loc in let file = Lm_symbol.to_string file in List [Magic LocationMagic; String file; Int sline; Int schar; Int eline; Int echar] let unmarshal_loc (l : msg) : Lm_location.t = match l with | List [Magic LocationMagic; String file; Int sline; Int schar; Int eline; Int echar] -> Lm_location.create_loc (Lm_symbol.add file) sline schar eline echar | _ -> raise MarshalError omake-0.10.3/src/libmojave/lm_map_sig.ml0000644000175000017500000001240713177364665016541 0ustar gerdgerd (************************************************************************ * Maps. *) module type OrderedType = sig type t val compare : t -> t -> int end module type LmMapBase = sig type key type 'a t val empty : 'a t val is_empty : 'a t -> bool val cardinal : 'a t -> int val add : 'a t -> key -> 'a -> 'a t val find : 'a t -> key -> 'a val remove : 'a t -> key -> 'a t val mem : 'a t -> key -> bool val find_key : 'a t -> key -> key option val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val fold : ('a -> key -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold_map : ('a -> key -> 'b -> 'a * 'c) -> 'a -> 'b t -> 'a * 'c t val forall2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool val forall : (key -> 'a -> bool) -> 'a t -> bool val exists : (key -> 'a -> bool) -> 'a t -> bool val find_iter : (key -> 'a -> 'b option) -> 'a t -> 'b option val isect_mem : 'a t -> (key -> bool) -> 'a t val choose : 'a t -> key * 'a val filter_add : 'a t -> key -> ('a option -> 'a) -> 'a t val filter_remove : 'a t -> key -> ('a -> 'a option) -> 'a t val replace : 'a t -> key -> ('a -> 'a) -> 'a t val keys : 'a t -> key list val data : 'a t -> 'a list val add_list : 'a t -> (key * 'a) list -> 'a t val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool end module type LmMap = sig include LmMapBase val union : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t end (* * This is the backwards-compatible version. *) module type S = sig type key type 'a t val empty : 'a t val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b end module type LmMapList = sig include LmMapBase val filter : 'a t -> key -> ('a list -> 'a list) -> 'a t val find_all : 'a t -> key -> 'a list val find_all_partial : 'a t -> key -> 'a list val iter_all : (key -> 'a list -> unit) -> 'a t -> unit val mapi_all : (key -> 'a list -> 'b list) -> 'a t -> 'b t val fold_all : ('a -> key -> 'b list -> 'a) -> 'a -> 'b t -> 'a val data_all : 'a t -> 'a list list val union : (key -> 'a list -> 'a list -> 'a list) -> 'a t -> 'a t -> 'a t val choose_all : 'a t -> key * 'a list end (************************************************************************ * Tables *) (* * The record of methods. *) type ('elt, 'data, 'table) table_methods = { empty : 'table; make : 'elt -> 'data list -> 'table; is_empty : 'table -> bool; mem : 'table -> 'elt -> bool; add : 'table -> 'elt -> 'data -> 'table; replace : 'table -> 'elt -> 'data list -> 'table; find : 'table -> 'elt -> 'data; find_all : 'table -> 'elt -> 'data list; remove : 'table -> 'elt -> 'table; union : 'table -> 'table -> 'table; elements : 'table -> ('elt * 'data list) list; iter : ('elt -> 'data -> unit) -> 'table -> unit; fold_map : ('elt -> 'data -> 'table -> 'table) -> 'table -> 'table -> 'table; map : ('elt -> 'data -> 'data) -> 'table -> 'table; cardinal : 'table -> int; mem_filt : 'table -> 'elt list -> 'elt list; not_mem_filt : 'table -> 'elt list -> 'elt list; intersectp : 'table -> 'table -> bool; of_list : ('elt * 'data list) list -> 'table; list_of : 'table -> ('elt * 'data list) list; deletemax : 'table -> ('elt * 'data list * 'table); (* Debugging *) print : out_channel -> 'table -> unit } (* * Creation functions. *) type ('elt, 'data, 'table) table_create_type = (out_channel -> 'elt -> 'data list -> unit) -> (* printer *) ('elt -> 'elt -> int) -> (* comparison function *) ('data list -> 'data list -> 'data list) -> (* append during union *) ('elt, 'data, 'table) table_methods (* * Module containing a creation function. *) module type TableCreateSig = sig type ('elt, 'data) t val create : ('elt, 'data, ('elt, 'data) t) table_create_type end (* * Ordering module. *) module type TableBaseSig = sig type elt type data val print : out_channel -> elt -> data list -> unit val compare : elt -> elt -> int val append : data list -> data list -> data list end (* * These are the functions provided by the table. *) module type TableSig = sig type elt type data type t val empty : t val is_empty : t -> bool val length : t -> int val add : t -> elt -> data -> t val replace : t -> elt -> data list -> t val union : t -> t -> t val mem : t -> elt -> bool val find : t -> elt -> data val find_all : t -> elt -> data list (* last added first *) val remove : t -> elt -> t val iter : (elt -> data -> unit) -> t -> unit val fold_map : (elt -> data -> t -> t) -> t -> t -> t val map : (elt -> data -> data) -> t -> t val list_of : t -> (elt * data list) list val deletemax : t -> (elt * data list * t) val print : out_channel -> t -> unit end omake-0.10.3/src/libmojave/lm_set_sig.ml0000644000175000017500000000260013177364665016551 0ustar gerdgerd module type OrderedType = sig type t val compare : t -> t -> int end (* * Ordered type need for debugging. *) module type OrderedTypeDebug = sig type t val print : t Lm_printf.t val compare : t -> t -> int end (* * Our version. *) module type LmSet = sig type elt type t val empty : t val is_empty : t -> bool val mem : t -> elt -> bool val add : t -> elt -> t val singleton : elt -> t val remove : t -> elt -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool (* * These two functions are identical. * subset s1 s2 tests whether s1 is a subset of s2. *) val subset : t -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val filter : (elt -> bool) -> t -> t val partition : (elt -> bool) -> t -> t * t val cardinal : t -> int val elements : t -> elt list val min_elt : t -> elt val max_elt : t -> elt val choose : t -> elt val find : elt -> t -> elt (** compared with standard set, missing [split] *) val of_list : elt list -> t val to_list : t -> elt list val add_list : t -> elt list -> t end module type LmSetDebug = sig include LmSet val print : t Lm_printf.t end omake-0.10.3/src/libmojave/lm_int_set.ml0000644000175000017500000000037513177364665016570 0ustar gerdgerdmodule OrderedInt = struct type t = int let compare (i : int) (j : int) = Pervasives.compare i j end module IntSet = Lm_set.LmMake (OrderedInt) module IntTable = Lm_map.LmMake (OrderedInt) module IntMTable = Lm_map.LmMakeList (OrderedInt) omake-0.10.3/src/libmojave/lm_channel.ml0000644000175000017500000007432713177364665016543 0ustar gerdgerd(* open Lm_printf *) (* * The channel may be a file, pipe, or socket. * !!!The ordering of these fields is important!!! * If you update this, fix the function omake_shell_pipe_kind() * in omake_shell_csys.c *) type kind = | FileChannel | PipeChannel | SocketChannel type mode = | InChannel | OutChannel | InOutChannel (* * Canonical names. *) let string_sym = Lm_symbol.add ".string" let fun_sym = Lm_symbol.add ".fun" (* * The channel has an input and output buffer. * In addition, on Win32, we may have threads * to perform asynchronous writes on pipes. *) type channel = { mutable channel_id : int; channel_fd : Unix.file_descr option; channel_kind : kind; channel_mode : mode; mutable channel_file : Lm_symbol.t; (* If not channel_binary, then perform win32 line-ending transformation *) mutable channel_binary : bool; (* * We keep track of line number information. * The start_* fields give the line and character * number at the beginning of the buffer. * * The middle_* fields give the information at some * arbitrary point between 0 and in_max. *) mutable start_line : int; mutable start_char : int; mutable middle_index : int; mutable middle_line : int; mutable middle_char : int; (* * in_index is the index of the next character in the input. * in_max is the total amount of data in the input buffer. *) mutable in_index : int; mutable in_max : int; mutable in_buffer : bytes; (* * For lexing from the buffer. * lex_index is the current input position when lexing. * Invariant: in_index <= lex_index <= in_max *) mutable lex_index : int; (* * out_max is the total amount of data in the output buffer. * If out_expand is true, the outbuffer is expanded instead * instead of flushing. *) out_expand : bool; mutable out_max : int; mutable out_buffer : bytes; (* * In text mode, the output is double-buffered because * of line ending translation. * INVARIANT: In binary mode, the write_buffer is the same as the out_buffer. * * write_pid is the pid of the output thread, or 0 if there is no output thread. * write_index is the amount of data that has been written to the file. * write_max is the total amount of data in the write_buffer. *) mutable write_pid : int; mutable write_index : int; mutable write_max : int; mutable write_buffer : bytes; (* * These are the actual read and write functions. *) mutable read_fun : bytes -> int -> int -> int; mutable write_fun : bytes -> int -> int -> int } type t = channel (* * This is the normal buffer size. *) let buf_size = 4096 (* * This is the maximum size we allow * the input buffer to grow when lexing. *) let lex_buf_size = 1 lsl 18 (* * We may be told that this is a pipe, but really figure out what kind it is. *) external pipe_kind : Unix.file_descr -> kind = "omake_shell_pipe_kind" (* * Default readers and writers. * * XXX: We treat the "broken pipe" errors as EOFs. *) let default_reader fd buf off len = match fd with | Some fd -> Lm_thread_pool.blocking_section (fun () -> try Unix.read fd buf off len with | Unix.Unix_error (Unix.EUNKNOWNERR 0, _, _) | Unix.Unix_error (Unix.EPIPE, _, _) -> 0) () | None -> raise (Unix.Unix_error (Unix.EINVAL, "default_reader", "")) (* * Convert a fd to an integer (for debugging). *) (* external int_of_fd : Unix.file_descr -> int = "int_of_fd" *) let default_writer fd buf off len = match fd with | Some fd -> Lm_thread_pool.blocking_section (fun () -> Unix.write fd buf off len) () | None -> raise (Unix.Unix_error (Unix.EINVAL, "default_writer", "")) (* * Readers and writers for string channels. *) let null_reader _ _ _ = 0 let null_writer _ _ _ = 0 (* * Empty buffer. *) let create file kind mode binary fd = let kind = match fd with Some fd -> if kind = PipeChannel then pipe_kind fd else kind | None -> kind in let binary = Sys.os_type <> "Win32" || binary in let out_buffer = Bytes.create buf_size in let write_buffer = if binary then out_buffer else Bytes.create (buf_size * 2) in { channel_id = 0; channel_fd = fd; channel_kind = kind; channel_mode = mode; channel_file = Lm_symbol.add file; channel_binary = Sys.os_type <> "Win32" || binary; start_line = 1; start_char = 0; middle_index = 0; middle_line = 1; middle_char = 0; in_index = 0; in_max = 0; in_buffer = Bytes.create (succ buf_size); lex_index = 0; out_max = 0; out_expand = false; out_buffer = out_buffer; write_pid = 0; write_index = 0; write_max = 0; write_buffer = write_buffer; read_fun = default_reader fd; write_fun = default_writer fd } let set_id info id = info.channel_id <- id let of_string file line char s = let len = String.length s in { channel_id = 0; channel_fd = None; channel_kind = FileChannel; channel_mode = InChannel; channel_file = file; channel_binary = true; start_line = line; start_char = char; middle_index = 0; middle_line = line; middle_char = char; in_index = 0; in_max = len; in_buffer = Bytes.of_string s; lex_index = 0; out_max = 0; out_expand = false; out_buffer = Bytes.create 0; write_pid = 0; write_index = 0; write_max = 0; write_buffer = Bytes.create 0; read_fun = null_reader; write_fun = null_writer } let of_fun read write = let out_buffer = Bytes.create buf_size in { channel_id = 0; channel_fd = None; channel_kind = FileChannel; channel_mode = InOutChannel; channel_file = fun_sym; channel_binary = true; start_line = 1; start_char = 0; middle_index = 0; middle_line = 1; middle_char = 0; in_index = 0; in_max = 0; in_buffer = Bytes.create buf_size; lex_index = 0; out_max = 0; out_expand = false; out_buffer = out_buffer; write_pid = 0; write_index = 0; write_max = 0; write_buffer = out_buffer; read_fun = read; write_fun = write } let of_loc_string file line char s = of_string (Lm_symbol.add file) line char s let of_substring s off len = of_string string_sym 1 0 (String.sub s off len) let of_string s = of_string string_sym 1 0 s let info channel = let { channel_id = id; channel_kind = kind; channel_mode = mode; channel_binary = binary; _ } = channel in id, kind, mode, binary let name channel = Lm_symbol.to_string channel.channel_file let descr channel = match channel.channel_fd with Some fd -> fd | None -> raise (Unix.Unix_error (Unix.EINVAL, "descr", "")) let set_binary_mode = if Sys.os_type = "Win32" then (fun info flag -> info.channel_binary <- flag) else (fun _ _ -> ()) let set_io_functions info reader writer = info.read_fun <- reader; info.write_fun <- writer let create_loc_string_aux file line char = let out_buffer = Bytes.create buf_size in { channel_id = 0; channel_fd = None; channel_kind = FileChannel; channel_mode = OutChannel; channel_file = file; channel_binary = true; start_line = line; start_char = char; middle_index = 0; middle_line = line; middle_char = char; in_index = 0; in_max = 0; in_buffer = Bytes.create 0; lex_index = 0; out_max = 0; out_expand = true; out_buffer = out_buffer; write_pid = 0; write_index = 0; write_max = 0; write_buffer = out_buffer; read_fun = null_reader; write_fun = null_writer } let create_loc_string file line char = create_loc_string_aux (Lm_symbol.add file) line char let create_string () = create_loc_string_aux string_sym 1 0 (************************************************************************ * Line envding translation. *) (* let debug_get s i = *) (* eprintf "String.get: %d[%d]@." (String.length s) i; *) (* String.get s i *) (* let debug_set s i c = *) (* eprintf "String.set: %d[%d]@." (String.length s) i; *) (* String.set s i c *) let bytes_get = Bytes.unsafe_get let bytes_set = Bytes.unsafe_set let expand_text obuffer omax wbuffer = assert (omax >= 0 && omax <= Bytes.length obuffer && omax * 2 <= Bytes.length wbuffer); let rec copy1 src dst = if src = omax then dst else match bytes_get obuffer src with '\n' -> bytes_set wbuffer dst '\r'; bytes_set wbuffer (succ dst) '\n'; copy1 (succ src) (dst + 2) | c -> bytes_set wbuffer dst c; copy1 (succ src) (succ dst) in copy1 0 0 let squash_text buffer off amount = assert (off >= 0 && amount >= 0 && off + amount <= Bytes.length buffer); if amount = 0 then 0 else let max = off + amount in let rec copy2 dst src = if src = max then dst - off else if src = max - 1 then begin bytes_set buffer dst (bytes_get buffer src); succ dst - off end else match bytes_get buffer src with '\r' when bytes_get buffer (succ src) = '\n' -> bytes_set buffer dst '\n'; copy2 (succ dst) (src + 2) | _ -> bytes_set buffer dst (bytes_get buffer src); copy2 (succ dst) (succ src) in copy2 off off (************************************************************************ * Line numbers. *) (* * Get the line/char for a particular point in the input buffer. *) let line_of_index info buffer index = let { start_line = start_line; start_char = start_char; middle_index = middle_index; middle_line = middle_line; middle_char = middle_char; _ } = info in let rec search line char i = if i = index then begin info.middle_index <- index; info.middle_line <- line; info.middle_char <- char; line, char end else if Bytes.get buffer i = '\n' then search (succ line) 0 (succ i) else search line (succ char) (succ i) in if index >= middle_index then search middle_line middle_char middle_index else search start_line start_char 0 (* * Reset the input buffer. * This resets the start line and position. *) let reset_input_buffer info = let line, char = line_of_index info info.in_buffer info.in_max in info.start_line <- line; info.start_char <- char; info.middle_index <- 0; info.middle_line <- line; info.middle_char <- char; info.in_max <- 0; info.in_index <- 0; info.lex_index <- 0 let shift_input_buffer info = let { in_buffer = in_buffer; in_index = in_index; lex_index = lex_index; in_max = in_max; _ } = info in let line, char = line_of_index info in_buffer in_index in Bytes.blit in_buffer in_index in_buffer 0 (in_max - in_index); info.start_line <- line; info.start_char <- char; info.middle_index <- 0; info.middle_line <- line; info.middle_char <- char; info.in_index <- 0; info.in_max <- in_max - in_index; info.lex_index <- lex_index - in_index let set_line info name line = shift_input_buffer info; info.start_line <- line; info.start_char <- 0; info.middle_line <- line; info.middle_char <- 0; info.channel_file <- Lm_symbol.add name (* * Reset the output buffer. * This resets the start line and position if this is a file. * For pipes and sockets, input and output are independent. *) let reset_output_buffer info = if info.channel_kind = FileChannel then begin let line, char = line_of_index info info.out_buffer info.out_max in info.start_line <- line; info.start_char <- char; info.middle_index <- 0; info.middle_line <- line; info.middle_char <- char end; info.out_max <- 0; info.write_index <- 0; info.write_max <- 0 (************************************************************************ * Output string buffers. *) (* * For string buffers, expand the output instead of * flushing. *) let expand_output info = let { out_buffer = buffer; out_max = max; _ } = info in if max = Bytes.length buffer then begin let buffer2 = Bytes.create (max * 2) in Bytes.blit buffer 0 buffer2 0 max; info.out_buffer <- buffer2; if info.channel_binary then info.write_buffer <- buffer2; end let to_string info = let { out_buffer = buffer; out_max = max; _ } = info in Bytes.sub_string buffer 0 max (************************************************************************ * Flushing and filling. *) (* * Flush the input. * When output is started, the remaining input is discarded. * Update the current position and line number information. *) let flush_input info = if info.channel_kind = FileChannel && info.in_max <> 0 then reset_input_buffer info (* * Start the write buffer. *) let setup_write_buffer info = if info.write_max = 0 then if info.channel_binary then begin info.write_index <- 0; info.write_max <- info.out_max end else let wmax = expand_text info.out_buffer info.out_max info.write_buffer in info.write_index <- 0; info.write_max <- wmax (* * Flush the buffer, but write only once. *) let flush_output_once info = setup_write_buffer info; let { write_index = off; write_max = max; write_buffer = buf; write_fun = write; _ } = info in let count = write buf off (max - off) in let off' = off + count in if off' = max then reset_output_buffer info else info.write_index <- off' (* * Flush the buffer. *) let flush_aux info = setup_write_buffer info; let { write_buffer = buf; write_fun = writer; _ } = info in (* Now write the data directly *) let rec write () = let { write_index = index; write_max = max; _ } = info in let len = max - index in if len <> 0 then let count = writer buf index len in info.write_index <- index + count; write () in write (); reset_output_buffer info let flush_output info = let pid = info.write_pid in if pid <> 0 then Lm_thread_pool.waitpid pid; if info.out_expand then expand_output info else flush_aux info (* * Start an output thread trying to write the data to the pipe. *) let start_output_thread info = let pid = info.write_pid in if pid = 0 then let pid = Lm_thread_pool.create false (fun () -> let () = try flush_aux info with Unix.Unix_error _ -> () in info.write_pid <- 0) in info.write_pid <- pid let start_output_threads wfd_pipe = List.iter start_output_thread wfd_pipe (* * Flush and close the channel. *) let close info = flush_input info; let () = try flush_output info with Unix.Unix_error _ -> () in match info.channel_fd with Some fd -> Unix.close fd | None -> () (* * Print a byte. *) let rec output_char info c = let { out_max = max; out_buffer = buffer; _ } = info in flush_input info; if max = Bytes.length buffer then begin flush_output info; output_char info c end else begin Bytes.set buffer max c; info.out_max <- succ max end let output_byte info c = output_char info (Char.chr c) (* * Write a substring. *) let rec output_buffer info buf off len = let { out_max = max; out_buffer = buffer; _ } = info in let avail = Bytes.length buffer - max in flush_input info; if len <> 0 then if avail = 0 then begin flush_output info; output_buffer info buf off len end else let amount = min avail len in Bytes.blit buf off buffer max amount; info.out_max <- max + amount; output_buffer info buf (off + amount) (len - amount) let output_string info s = let buf = Bytes.of_string s in output_buffer info buf 0 (Bytes.length buf) (* * Write allows for partial writes. * This is always in binary mode. *) let write info (buf:bytes) off len = flush_input info; flush_output info; info.write_fun buf off len (* * Check if there is input already in the buffer. *) let poll info = let { in_index = index; in_max = max; _ } = info in index <> max (* * Get data when the buffer is empty. *) let fillbuf info = let { channel_binary = binary; in_buffer = buf; read_fun = reader; _ } = info in let count = reader buf 0 buf_size in let count = if count = 0 then raise End_of_file; if binary then count else let extra = (* Read one extra char if we got an unfortunate read *) if Bytes.get buf (pred count) = '\r' then reader buf count 1 else 0 in squash_text buf 0 (count + extra) in info.in_index <- 0; info.in_max <- count (* * Get a single char. *) let rec input_char info = let { in_index = index; in_max = max; in_buffer = buf; _ } = info in flush_output info; if index = max then begin fillbuf info; input_char info end else let c = Bytes.get buf index in info.in_index <- succ index; c (* * Translate to an integer. *) let input_byte info = Char.code (input_char info) (* * Read data into a buffer. *) let rec input_buffer info s off len = let { in_index = index; in_max = max; in_buffer = buf; _ } = info in let avail = max - index in flush_output info; if len <> 0 then if avail = 0 then begin fillbuf info; input_buffer info s off len end else let amount = min avail len in let new_len = len - amount in let new_off = off + amount in Bytes.blit buf index s off amount; info.in_index <- index + amount; input_buffer info s new_off new_len (* * Read a line, do not include the line-ending. *) let input_line info = let buf = Buffer.create 80 in let rec collect () = let c = input_char info in if c = '\n' then Buffer.contents buf else begin Buffer.add_char buf c; collect () end in try collect () with End_of_file when Buffer.length buf <> 0 -> Buffer.contents buf (* * Read a line, include the line-ending. *) let input_entire_line info = let buf = Buffer.create 80 in let rec collect () = let c = input_char info in Buffer.add_char buf c; if c = '\n' then Buffer.contents buf else collect () in try collect () with End_of_file when Buffer.length buf <> 0 -> Buffer.contents buf (* * Read allows for partial reading. *) let read info s off len = let { in_index = index; in_max = max; in_buffer = buf; read_fun = reader; _ } = info in let avail = max - index in flush_output info; if avail = 0 then reader s off len else let amount = min len avail in Bytes.blit buf index s off amount; info.in_index <- index + amount; amount (* * Export the flusher. *) let flush = flush_output (* * Positioning. * The tell function is unreliable on text files. *) let tell info = let pos = Unix.lseek (descr info) 0 Unix.SEEK_CUR in if info.out_max <> 0 then pos + info.out_max else pos + info.in_index let seek info pos whence = flush_output info; flush_input info; Unix.lseek (descr info) pos whence (* * Get the current location. *) let loc info = let { out_max = out_max; in_index = in_index; in_buffer = in_buffer; out_buffer = out_buffer; channel_file = file; _ } = info in let line, char = if out_max <> 0 then line_of_index info out_buffer out_max else line_of_index info in_buffer in_index in Lm_location.create_loc file line char line char (************************************************************************ * Select. * Bah, this is tough on Win32. *) let rec classify files pipes sockets fdl = match fdl with fd :: fdl -> let files, pipes, sockets = match fd.channel_kind with FileChannel -> fd :: files, pipes, sockets | PipeChannel -> files, fd :: pipes, sockets | SocketChannel -> files, pipes, fd :: sockets in classify files pipes sockets fdl | [] -> files, pipes, sockets (* * Find input channels with nonempty buffers. *) let rec find_read_nonempty l rfd = match rfd with fd :: rfd -> let l = if fd.in_max <> fd.in_index then fd :: l else l in find_read_nonempty l rfd | [] -> l (* * Find output channels with empty buffers. *) let rec find_write_empty l wfd = match wfd with fd :: wfd -> let l = if fd.out_max = 0 || fd.out_expand then fd :: l else l in find_write_empty l wfd | [] -> l (* * Look at all the input pipes and see if any data is available. *) external peek_pipe : Unix.file_descr -> bool = "omake_shell_peek_pipe" let rec peek_pipes l pipes = match pipes with pipe :: pipes -> let l = if peek_pipe (descr pipe) then pipe :: l else l in peek_pipes l pipes | [] -> l (* * Aux function to translate between descriptors and channels. *) let select_aux rfd_sockets wfd_sockets efd_sockets timeout = let rfd = List.map descr rfd_sockets in let wfd = List.map descr wfd_sockets in let efd = List.map descr efd_sockets in let rfd, wfd, efd = Unix.select rfd wfd efd timeout in let rfd_sockets = List.filter (fun fd -> List.mem (descr fd) rfd) rfd_sockets in let wfd_sockets, wrote = List.fold_left (fun (wfd_sockets, wrote) fd -> if List.mem (descr fd) wfd then let wrote = if fd.out_max <> 0 then begin flush_output_once fd; true end else wrote in fd :: wfd_sockets, wrote else wfd_sockets, wrote) ([], false) wfd_sockets in let efd_sockets = List.filter (fun fd -> List.mem (descr fd) efd) efd_sockets in rfd_sockets, wfd_sockets, efd_sockets, wrote (* * Periodically poll to see if something has happened. * If necessary, poll interval is 50msec. *) let poll_interval = 0.050 let rec select_poll rfd_pipes rfd_sockets wfd_pipes wfd_sockets efd_sockets expire = let wfd_empty = find_write_empty [] wfd_pipes in if wfd_empty <> [] then [], wfd_empty, [] else (* Peek at the pipes and see if they are ready for reading *) let rfd_pipes_ready = peek_pipes [] rfd_pipes in if rfd_pipes_ready <> [] then rfd_pipes_ready, [], [] else (* Start the writer threads for the pipes *) let () = start_output_threads wfd_pipes in (* Compute the nest polling interval *) let timeout, final_attempt = if rfd_pipes = [] && wfd_pipes = [] then let now = Unix.gettimeofday () in let timeout = expire -. now in max timeout 0.0, true else if expire < 0.0 then poll_interval, false else let now = Unix.gettimeofday () in let timeout = expire -. now in if timeout < poll_interval then max timeout 0.0, true else poll_interval, false in (* Perform the select on the sockets *) let rfd, wfd, efd, wrote = select_aux rfd_sockets wfd_sockets efd_sockets timeout in if rfd <> [] || wfd <> [] || efd <> [] then (* Success with a socket *) rfd, wfd, efd else if final_attempt && not wrote then (* Reached the timeout *) [], [], [] else (* Timeout occurred, try again *) select_poll rfd_pipes rfd_sockets wfd_pipes wfd_sockets efd_sockets expire (* * If there are no pipes, just call select directly. *) let select rfd wfd efd timeout = let rfd_files, rfd_pipes, rfd_sockets = classify [] [] [] rfd in let wfd_files, wfd_pipes, wfd_sockets = classify [] [] [] wfd in let efd_files, _efd_pipes, efd_sockets = classify [] [] [] efd in if rfd_files <> [] || wfd_files <> [] || efd_files <> [] then rfd_files, wfd_files, efd_files else let rfd_nonempty = find_read_nonempty [] rfd_pipes in let rfd_nonempty = find_read_nonempty rfd_nonempty rfd_sockets in if rfd_nonempty <> [] then rfd_nonempty, [], [] else let expire = if timeout <= 0.0 then timeout else Unix.gettimeofday () +. timeout in select_poll rfd_pipes rfd_sockets wfd_pipes wfd_sockets efd_sockets expire (************************************************************************ * Lexing functions. * * When the lexer is working, it needs to buffer *all* the input, * so we never throw the input away. *) module LexerInput = struct type t = channel (* * These are special characters used to identify begin-of-file * and end-of-file conditions. *) let eof = -1 let bof = -2 (* * Start lex mode. *) let lex_start channel = let { in_index = index; in_buffer = buffer; _ } = channel in let prev = if index = 0 then bof else Char.code (Bytes.get buffer (pred index)) in channel.lex_index <- channel.in_index; prev (* * Restart at a previous position. *) let lex_restart channel pos = let { in_max = max; in_index = index; _ } = channel in assert (pos >= 0 && pos <= max - index); channel.lex_index <- index + pos (* * Stop lexing. * The argument is how much data was read in lex mode. *) let lex_stop channel pos = channel.in_index <- channel.in_index + pos; assert(channel.in_index <= channel.in_max) (* * Get the string matched by the lexer. *) let lex_string channel pos = let { in_index = start; in_buffer = buffer; _ } = channel in Bytes.sub_string buffer start pos (* * Get the string matched by the lexer. *) let lex_substring channel off len = let { in_index = start; in_buffer = buffer; _ } = channel in Bytes.sub_string buffer (start + off) len (* * Fill the buffer in lex mode. * We can't discard any of the existing data. *) let rec lex_fill channel = let { in_max = max; in_buffer = buffer; in_index = start; read_fun = reader; channel_binary = binary; _ } = channel in let len = Bytes.length buffer in let amount = len - max in (* If we have space, fill it *) if amount > 1 then let count = reader buffer max (pred amount) in if count = 0 then eof else let count = if binary then count else let extra = if Bytes.get buffer (max + count - 1) = '\r' then reader buffer (max + count) 1 else 0 in squash_text buffer max (count + extra) in let c = Bytes.get buffer max in channel.in_max <- max + count; channel.lex_index <- succ max; Char.code c (* If we can shift left, do it *) else if start <> 0 then begin shift_input_buffer channel; lex_fill channel end (* If the buffer is already too big, return eof *) else if len >= lex_buf_size then eof (* * Otherwise grow it. *) else let new_buffer = Bytes.create (Pervasives.max (len * 2) 32) in Bytes.blit buffer 0 new_buffer 0 max; channel.in_buffer <- new_buffer; lex_fill channel (* * Get the next character in lex mode. *) let lex_next channel = let { in_max = max; in_buffer = buffer; lex_index = index; _ } = channel in if index = max then lex_fill channel else let c = Bytes.get buffer index in channel.lex_index <- succ index; Char.code c (* * Get the current position in lex mode. *) let lex_pos channel = channel.lex_index - channel.in_index (* * Get the location of the buffer. *) let lex_loc channel off = let { start_line = line; start_char = char; channel_file = file; lex_index = index; in_buffer = buffer; in_max = max; _ } = channel in let line1, char1 = if index > max then line, char else line_of_index channel buffer index in let line2, char2 = if index + off > max then line1, char1 else line_of_index channel buffer (index + off) in Lm_location.create_loc file line1 char1 line2 char2 (* * Add any remaining buffered text to a buffer. *) let lex_buffer channel buf = let { in_max = max; in_buffer = buffer; in_index = start; _ } = channel in Buffer.add_subbytes buf buffer start (max - start); channel.in_index <- max end (* * -*- * Local Variables: * End: * -*- *) omake-0.10.3/src/libmojave/lm_termsize.ml0000644000175000017500000000200413177364665016754 0ustar gerdgerdopen Unix open Lm_debug open! Lm_printf let debug_terminal = create_debug { debug_name = "terminal"; debug_description = "show terminal size operations"; debug_value = false } external term_size : file_descr -> int * int = "caml_term_size" let min_screen_width = ref 40 let term_width_fd fd width = try let _, cols = term_size fd in if !debug_terminal then eprintf "Terminal size: requested %i, got %i, minimal witdth is %i%t" width cols (!min_screen_width) eflush; max (!min_screen_width) cols with Failure s -> if !debug_terminal then eprintf "Can't get terminal size: %s%t" s eflush; width let term_width out width = term_width_fd (descr_of_out_channel out) width let stdout_width = term_width_fd Unix.stdout 80 let stderr_width = term_width_fd Unix.stderr 80 let () = if stdout_width <> 80 then pp_set_margin std_formatter stdout_width; if stderr_width <> 80 then pp_set_margin err_formatter stderr_width omake-0.10.3/src/libmojave/lm_terminfo.ml0000644000175000017500000000532713177364665016750 0ustar gerdgerd(* * Simple terminfo interface. * Copyright (C) 2002 Justin David Smith, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. *) (* The C function takes a string ID, and returns the escape sequence (or an empty string if the ID is not defined for this terminal). *) external caml_tgetstr_enabled : unit -> bool = "caml_tgetstr_enabled" external caml_tgetstr : string -> string = "caml_tgetstr" external get_number_of_cores : unit -> int = "caml_get_number_of_cores" (* Tgetstr is enabled only if the terminal is defined *) let tgetstr_enabled = caml_tgetstr_enabled () (* tgetstr id Lookup the terminal capability with indicated id. This assumes the terminfo to lookup is given in the TERM environment variable. This function returns None if the terminal capability is not defined. *) let tgetstr id = if tgetstr_enabled then let result = caml_tgetstr id in if result = "" then None else Some result else None (* Various terminfo identifier names for use with tgetstr *) let enter_bold_mode = "bold" let exit_attribute_mode = "sgr0" (* xterm_ok () Check for an XTerm-compatible terminal, for the XTerm escapes. *) (* XXX: strictly speaking, we should be using the "tsl"/"fsl" capabilities here, but those are often missing *) let xterm_ok () = try match Sys.getenv "TERM" with "xterm" | "color_xterm" | "xterm-color" | "konsole" | "rxvt" -> true | _ -> false with Not_found -> false (* xterm_escape_begin () Display XTerm title begin escape, if available. *) let xterm_escape_begin () = if xterm_ok () then Some "\027]0;" else None (* xterm_escape_begin () Display XTerm title end escape, if available. *) let xterm_escape_end () = if xterm_ok () then Some "\007" else None omake-0.10.3/src/libmojave/lm_location.ml0000644000175000017500000000423413177364665016731 0ustar gerdgerd(* * Source locations. *) (* XXX: TODO: we should switch to using MLast.loc instead *) (* * A location is a character range * filename, start_line, start_char, end_line, end_char *) (* %%MAGICBEGIN%% *) type t = Lm_symbol.t * int * int * int * int (* %%MAGICEND%% *) (* GS TODO. type t = Lexing.position * Lexing.position *) (* * Comparison. *) let compare (**) (v1, start_line1, start_char1, end_line1, end_char1) (v2, start_line2, start_char2, end_line2, end_char2) = let cmp = Lm_symbol.compare v1 v2 in if cmp = 0 then let cmp = start_line1 - start_line2 in if cmp = 0 then let cmp = start_char1 - start_char2 in if cmp = 0 then let cmp = end_line1 - end_line2 in if cmp = 0 then end_char1 - end_char2 else cmp else cmp else cmp else cmp (* * Source location if all else fails. *) let bogus_loc name = Lm_symbol.add name, 0, 0, 0, 0 (* * Normal location. *) let create_loc name start_line start_char end_line end_char = name, start_line, start_char, end_line, end_char (* * For marshaling. *) let dest_loc (name, start_line, start_char, end_line, end_char) = name, start_line, start_char, end_line, end_char (* * Union of locations. *) let union_loc loc1 loc2 = let file1, start_line1, start_char1, _, _ = loc1 in let file2, _, _, end_line2, end_char2 = loc2 in if file1 = file2 then (file1, start_line1, start_char1, end_line2, end_char2) else loc1 (* * Print a file location. *) let pp_print_location buf (file, start_line, start_char, end_line, end_char) = Format.fprintf buf "File %a: " Lm_symbol.output_symbol file; if start_line = end_line then Format.fprintf buf "line %d, characters %d-%d" start_line start_char end_char else Format.fprintf buf "lines %d:%d-%d:%d" start_line start_char end_line end_char let string_of_location loc = pp_print_location Format.str_formatter loc; Format.flush_str_formatter () omake-0.10.3/src/libmojave/lm_readline.ml0000644000175000017500000000301113177364665016674 0ustar gerdgerdexternal flush : unit -> unit = "omake_readline_flush" external isatty : unit -> bool = "omake_isatty" external is_interactive : unit -> bool = "omake_is_interactive" external set_interactive : bool -> unit = "omake_interactive" external init : unit -> unit = "omake_readline_init" external where : unit -> int = "omake_where_history" external history : unit -> string array = "omake_readline_history" external load : string -> unit = "omake_readline_load_file" external save : unit -> unit = "omake_readline_save_file" external set_length : int -> unit = "omake_readline_set_length" external set_directory : string -> unit = "omake_readline_set_directory" external get_prompt_invs : unit -> string * string = "omake_rl_prompt_wrappers" let () = init () let prompt_invisible = match get_prompt_invs () with | "", "" -> None | inv -> Some inv external ext_readline : string -> string = "omake_readline" external ext_readstring : string -> string -> int -> int -> int = "omake_readstring" let readline s = Lm_thread_pool.blocking_section ext_readline s let readstring s buf off len = Lm_thread_pool.blocking_section (ext_readstring s buf off) len omake-0.10.3/src/libmojave/lm_position.ml0000644000175000017500000001054113177364665016763 0ustar gerdgerd let debug_pos = Lm_debug.create_debug (**) { debug_name = "pos"; debug_description = "print verbose position information for debugging"; debug_value = false } let trace_pos = Lm_debug.create_debug (**) { debug_name = "trace_pos"; debug_description = "print position trace for debugging"; debug_value = false } (* * We include the name of the module where * the position is created. The value is a location, * a raw value, or a value with another position. *) (* %%MAGICBEGIN%% *) type 'a pos = string * 'a exn_loc and 'a exn_loc = | Loc of Lm_location.t | Base of 'a | Cons of 'a * 'a pos | ConsLoc of Lm_location.t * 'a pos | Pos of 'a pos * 'a pos | Int of int * 'a pos | String of string * 'a pos | Symbol of Lm_symbol.t * 'a pos | Del of (Format.formatter -> unit) * Lm_location.t | DelExp of (Format.formatter -> unit) * 'a pos (* %%MAGICEND%% *) module MakePos (Name : sig type t (* This is the name of the module where the position info is created *) val name : string (* Utilities for managing values *) val loc_of_t : t -> Lm_location.t val pp_print_t : t Lm_printf.t end ) = struct type t = Name.t (* * Get the source location for an exception. *) let rec loc_of_pos (_, pos) = match pos with | Loc loc | Del (_, loc) | ConsLoc (loc, _) -> loc | Base x -> Name.loc_of_t x | Cons (_, pos) | Pos (_, pos) | Int (_, pos) | String (_, pos) | Symbol (_, pos) | DelExp (_, pos) -> loc_of_pos pos (* * Print debugging info. *) let rec pp_print_pos buf (name, e) = match e with | Loc _ -> () | Base x -> Format.fprintf buf "@ %s.%a" name Name.pp_print_t x | Cons (x, pos) -> pp_print_pos buf pos; Format.fprintf buf "@ /%s.%a" name Name.pp_print_t x | ConsLoc (_, pos) -> pp_print_pos buf pos | Pos (pos1, pos2) -> Format.fprintf buf "@ @[Called from: %s%a@]%a" (**) name pp_print_pos pos1 pp_print_pos pos2 | String (s, pos) -> Format.fprintf buf "%a@ /%s.%s" pp_print_pos pos name s | Int (i, pos) -> Format.fprintf buf "%a@ %s.%d" pp_print_pos pos name i | Symbol (v, pos) -> Format.fprintf buf "%a@ %s.%a" pp_print_pos pos name Lm_symbol.output_symbol v | Del (f, _) -> Format.fprintf buf "@ %t" f | DelExp (f, pos) -> Format.fprintf buf "%a@ %t" pp_print_pos pos f (* * Real error printer. *) let pp_print_pos buf pos = Format.fprintf buf "@[%a" Lm_location.pp_print_location (loc_of_pos pos); if !debug_pos then pp_print_pos buf pos; Format.fprintf buf "@]" (* * Base values. *) let loc_exp_pos loc = if !trace_pos then Format.eprintf "Lm_trace: %s.%a@." Name.name Lm_location.pp_print_location loc; Name.name, Loc loc let loc_pos loc pos = if !trace_pos then Format.eprintf "Lm_trace: %s.loc@." Name.name; Name.name, ConsLoc (loc, pos) let base_pos x = if !trace_pos then Format.eprintf "Lm_trace: %s.base@." Name.name; Name.name, Base x let pos_pos pos1 pos2 = if !trace_pos then Format.eprintf "Lm_trace: %s.pos@." Name.name; if !debug_pos then Name.name, Pos (pos1, pos2) else pos2 let cons_pos x pos = if !trace_pos then Format.eprintf "Lm_trace: %s.cons@." Name.name; if !debug_pos then Name.name, Cons (x, pos) else pos let int_pos i pos = if !trace_pos then Format.eprintf "Lm_trace: %s.int: %d@." Name.name i; if !debug_pos then Name.name, Int (i, pos) else pos let string_pos s pos = if !trace_pos then Format.eprintf "Lm_trace: %s.string: %s@." Name.name s; if !debug_pos then Name.name, String (s, pos) else pos let symbol_pos v pos = if !trace_pos then Format.eprintf "Lm_trace: %s.symbol: %a@." Name.name Lm_symbol.output_symbol v; if !debug_pos then Name.name, Symbol (v, pos) else pos let del_pos f loc = if !trace_pos then Format.eprintf "Lm_trace: %s.delayed@." Name.name; Name.name, Del (f, loc) let del_exp_pos f pos = if !trace_pos then Format.eprintf "Lm_trace: %s.delayed@." Name.name; if !debug_pos then Name.name, DelExp (f, pos) else pos end omake-0.10.3/src/libmojave/lm_unix_util.ml0000644000175000017500000001500013177364665017132 0ustar gerdgerdtype registry_hkey = | HKEY_CLASSES_ROOT | HKEY_CURRENT_CONFIG | HKEY_CURRENT_USER | HKEY_LOCAL_MACHINE | HKEY_USERS (* external print_stack_pointer : unit -> unit = "lm_print_stack_pointer" *) external registry_find : registry_hkey -> string -> string -> string = "caml_registry_find" external getpwents : unit -> Unix.passwd_entry list = "lm_getpwents" external moncontrol : bool -> unit = "lm_moncontrol" let pp_time buf secs = if secs < 60. then Format.fprintf buf "%0.2f sec" secs else let subsec, sec = modf secs in let sec = int_of_float sec in let h = sec / 3600 in let m = (sec / 60) mod 60 in let s = sec mod 60 in if h > 0 then Format.fprintf buf "%d hrs %02d min %05.2f sec" h m (float s +. subsec) else Format.fprintf buf "%d min %05.2f sec" m (float s +. subsec) (* * Read the exact amount. *) let rec really_read fd (buf : bytes) off len = if len <> 0 then let amount = Unix.read fd buf off len in if amount = 0 then failwith "really_read" else really_read fd buf (off + amount) (len - amount) let rec complete_write fd buf off len = let count = Unix.write fd buf off len in if count < len then complete_write fd buf (off + count) (len - count) let rec copy_file_fd (buffer : bytes) from_fd to_fd = let count = Unix.read from_fd buffer 0 (Bytes.length buffer) in if count > 0 then begin complete_write to_fd buffer 0 count; copy_file_fd buffer from_fd to_fd end let finally x f action = match f x with | exception e -> action x; raise e | v -> action x; v let with_file_fmt (file : string) (action : Format.formatter -> 'a) : 'a = let outx = Pervasives.open_out_gen [Open_wronly; Open_binary; Open_creat; Open_append] 0o600 file in let buf = Format.formatter_of_out_channel outx in match action buf with | exception e -> close_out outx ; raise e | v -> close_out outx ; v let need_close fd f = match f fd with | exception e -> Unix.close fd ; raise e | v -> v let copy_file from_name to_name mode = let from_fd = Unix.openfile from_name [O_RDONLY] 0o666 in need_close from_fd (function from_fd -> let to_fd = Unix.openfile to_name [O_WRONLY; O_CREAT; O_TRUNC] 0o600 in need_close to_fd (function to_fd -> copy_file_fd (Bytes.create 8192) from_fd to_fd; if Sys.os_type <> "Win32" then Unix.fchmod to_fd mode else Unix.chmod to_name mode ) ) (* * Make a directory hierarchy. *) let mkdirhier name = let rec mkdir head path = match path with | dir :: rest -> let filename = Filename.concat head dir in (* If it is already a directory, keep it *) let is_dir = try (Unix.LargeFile.stat filename).Unix.LargeFile.st_kind = Unix.S_DIR with Unix.Unix_error _ -> false in if not is_dir then Unix.mkdir filename 0o777; mkdir filename rest | [] -> () in let head = if String.length name = 0 || name.[0] <> '/' then "." else "/" in let path = Lm_filename_util.split_path name in let path = Lm_filename_util.simplify_path path in mkdir head path (* * Compatibility initializer. *) external init : unit -> unit = "lm_compat_init" let () = init () (* * Get the pid of the process holding the lock *) external lm_getlk : Unix.file_descr -> Unix.lock_command -> int = "lm_getlk" let getlk fd cmd = let res = lm_getlk fd cmd in if res = 0 then None else Some res (* * Convert a fd to an integer (for debugging). *) external int_of_fd : Unix.file_descr -> int = "int_of_fd" (* * Win32 functions. *) external home_win32 : unit -> string = "home_win32" external lockf_win32 : Unix.file_descr -> Unix.lock_command -> int -> unit = "lockf_win32" external ftruncate_win32 : Unix.file_descr -> unit = "ftruncate_win32" (* * Try to figure out the home directory as best as possible. *) let find_home_dir () = try Sys.getenv "HOME" with Not_found -> let home = try (Unix.getpwnam (Unix.getlogin ())).Unix.pw_dir with Not_found | Unix.Unix_error _ -> Format.eprintf "!!! Lm_unix_util.find_home_dir:@."; Format.eprintf "!!! You have no home directory.@."; Format.eprintf "!!! Please set the HOME environment variable to a suitable directory.@."; raise (Invalid_argument "Lm_unix_util.find_home_dir") in Unix.putenv "HOME" home; home let application_dir = if Sys.os_type = "Win32" then try home_win32 () with Failure _ -> find_home_dir () else find_home_dir () let home_dir = if Sys.os_type = "Win32" then try Sys.getenv "HOME" with Not_found -> let home = application_dir in Unix.putenv "HOME" home; home else application_dir let lockf = ( if Sys.os_type = "Win32" then (fun fd cmd off -> try lockf_win32 fd cmd off with Failure "lockf_win32: already locked" -> raise (Unix.Unix_error(Unix.EAGAIN, "lockf", "")) | Failure "lockf_win32: possible deadlock" -> raise (Unix.Unix_error(Unix.EDEADLK, "lockf", ""))) else Unix.lockf )[@ocaml.warning "-52"] let ftruncate = if Sys.os_type = "Win32" then ftruncate_win32 else (fun fd -> Unix.ftruncate fd (Unix.lseek fd 0 Unix.SEEK_CUR)) type flock_command = LOCK_UN | LOCK_SH | LOCK_EX | LOCK_TSH | LOCK_TEX external flock : Unix.file_descr -> flock_command -> unit = "lm_flock" (* * Open a file descriptor. * This hook is here so you can add print statements to * help find file descriptor leaks. *) let openfile = Unix.openfile (* * Directory listing. *) let list_directory dir = let dirx = try Some (Unix.opendir dir) with Unix.Unix_error _ -> None in match dirx with None -> [] | Some dirx -> let rec list entries = let name = try Some (Unix.readdir dirx) with Unix.Unix_error _ | End_of_file -> None in match name with Some "." | Some ".." -> list entries | Some name -> list (Filename.concat dir name :: entries) | None -> entries in let entries = list [] in Unix.closedir dirx; entries (** Unlink a file, no errors. *) let try_unlink_file filename = try Unix.unlink filename with Unix.Unix_error _ -> () omake-0.10.3/src/libmojave/lm_hash_code.ml0000644000175000017500000024441713177364665017047 0ustar gerdgerd(************************************************************************ * Better-than usual hash functions. * * BUG: JYH: this hash is entirely ad-hoc. The idea here is the following. * If we were able, we would use the message as an index into a random function. * We can't do that, so jump around in a smaller table. * * We construct the hash on-the-fly, using a table of random numbers. *) (* %%MAGICBEGIN%% *) let hash_length = 6229 (* Must be a prime *) let digest_length = 16 let hash_data = [|0x04a018c6; 0x5ba7b0f2; 0x04dcf08b; 0x1e5a22cc; 0x2523b9ea; 0x4b92b691; 0x0bcaf015; 0x0a5d5109; 0x64d3be71; 0x5fbc0769; 0x3ac35af5; 0x77136b9a; 0x64e16501; 0x24d1efb9; 0x3835ad79; 0x103ac74f; 0x217edbb5; 0x33afeced; 0x1d9341e3; 0x116c3c4e; 0x01d3893a; 0x2657d18f; 0x324ea1ad; 0x20d56ec8; 0x2361f48d; 0x50b71a60; 0x1ced96bf; 0x2c06ba13; 0x6a7d99e2; 0x213818ce; 0x182ab58e; 0x05964edf; 0x049425a9; 0x2fa55545; 0x79c6238c; 0x33ee6060; 0x188796a1; 0x27650997; 0x48dbd56a; 0x51a7dedc; 0x69b54b8e; 0x06135229; 0x1db1f87f; 0x0c72761c; 0x4974fbd3; 0x71657506; 0x2f8b6b68; 0x247cabda; 0x71d47c35; 0x491e0036; 0x7da4c370; 0x5682e7c0; 0x5cf7c110; 0x0526f878; 0x262025fa; 0x41a19673; 0x330e9047; 0x11980c36; 0x6ce02397; 0x0ceba603; 0x43a00345; 0x063c1716; 0x538cb4aa; 0x2f60b5d7; 0x34943a0e; 0x56b7664c; 0x098cfa23; 0x1a64380e; 0x0ad1f7f3; 0x11a53f1f; 0x5b00d01e; 0x24bbd12d; 0x2401aafe; 0x1149c2d3; 0x07021acf; 0x1f4ed7d2; 0x3d23c6bc; 0x38dfe52c; 0x3a8e4667; 0x6050bb6d; 0x691f94eb; 0x537e771e; 0x2a9e04c1; 0x37050e1c; 0x73d70b51; 0x2c67f1ff; 0x6709d487; 0x7266f595; 0x36fd1713; 0x17e3d678; 0x1751280b; 0x2003a7dd; 0x05bd861d; 0x6b538252; 0x4465c159; 0x3298cb7d; 0x1489fbe8; 0x0833c615; 0x3aea7136; 0x2103f36d; 0x518acb8a; 0x0c4a0c83; 0x5418f7ed; 0x4ff40db4; 0x6db84908; 0x2dd59f9d; 0x531a8372; 0x61d38c25; 0x3554dc6c; 0x073bb1c8; 0x10f82b8b; 0x574175dc; 0x13966434; 0x7dfa6cd3; 0x69ed4f17; 0x62d4b072; 0x1890c649; 0x24052c29; 0x5b8dc934; 0x39833efb; 0x79f5a355; 0x7d026da5; 0x1b1d310e; 0x211ecd0d; 0x2fdd9c20; 0x6ef9ebc6; 0x36dd158a; 0x10ffca06; 0x52b38469; 0x74947de8; 0x6b3b1cbe; 0x680c4e82; 0x2657c2e2; 0x781e0f72; 0x145d923f; 0x6f321a9e; 0x1f4402f5; 0x17392d1c; 0x352a5c33; 0x63840b4e; 0x4fd97839; 0x7a389dd1; 0x3343eb86; 0x04cc72c3; 0x7cbba01e; 0x64cee4ad; 0x5c1f9282; 0x2de8158b; 0x2941291d; 0x30a3c118; 0x2070d8e8; 0x08503556; 0x52694d55; 0x2de9ec28; 0x16667c6f; 0x2431a2c7; 0x71f2122e; 0x5b011553; 0x308d4cd1; 0x7db98b06; 0x5d145510; 0x06040108; 0x5e078a62; 0x0d87bf4e; 0x4c20d8c2; 0x3171964d; 0x2a550059; 0x6a8b2d96; 0x621079cb; 0x5f400e32; 0x5c78b895; 0x7863cc1f; 0x1857902c; 0x5ab77c01; 0x3922ad96; 0x3ec74313; 0x090ff562; 0x7d8dc2d9; 0x77ccc196; 0x274aa8ec; 0x20e7d058; 0x5d451da4; 0x38411944; 0x16c92ac5; 0x17c532ca; 0x387b6c9e; 0x04599060; 0x42d41b08; 0x50b480fe; 0x60b6a668; 0x59bf878b; 0x40ecd7ff; 0x3c3a0e5f; 0x2226ba1f; 0x00b480d2; 0x27d243ce; 0x1b4fd4ac; 0x5452c80a; 0x6a055d72; 0x0e4f2f5f; 0x73561052; 0x1e34c368; 0x5c3f2470; 0x0ada6aca; 0x28f33428; 0x54d04532; 0x71a49cc1; 0x4488adb3; 0x620ea825; 0x6e3c834a; 0x3580610e; 0x1acc45ab; 0x7dcf080e; 0x396d3242; 0x2b6c8a54; 0x438e8578; 0x506170bc; 0x02021c1c; 0x41d6f98c; 0x5d198360; 0x449a1a80; 0x47d51424; 0x046a749f; 0x68caf27a; 0x15345f3a; 0x1edc6ace; 0x6b708fe1; 0x013dfa00; 0x7675676d; 0x4efa193c; 0x7f29b2b7; 0x55c10973; 0x524894bb; 0x27b5ef49; 0x399ee9c8; 0x7570a9e8; 0x5ad98886; 0x68c17a3a; 0x70b75e37; 0x102fdd4f; 0x678c6368; 0x6ab7b144; 0x781fe959; 0x45ba0108; 0x77746bf9; 0x0bb0a4a1; 0x63e3e01e; 0x08af1ae8; 0x039963f7; 0x229bc81d; 0x4c123bf6; 0x2bd90b99; 0x0f813575; 0x29c6378f; 0x084561f2; 0x222f7d94; 0x4a161957; 0x3fe15590; 0x616a3e1f; 0x6db1f066; 0x11b78394; 0x2791bafa; 0x0a634f2b; 0x7434ecb4; 0x52b86ca4; 0x4c236a71; 0x7cb4bf8a; 0x1a449dcc; 0x4ccc5386; 0x45ff9435; 0x0f9c5572; 0x6c0a91bb; 0x02182c23; 0x3e1fb322; 0x5bb9834e; 0x076ab97e; 0x3901cfcf; 0x398f5f59; 0x1f5e398e; 0x3423ba34; 0x02531acd; 0x54aba737; 0x74826232; 0x195f5564; 0x6fb5bd70; 0x217a2270; 0x4453067b; 0x3867017e; 0x2f5ea4ad; 0x5921c43f; 0x3699b3b4; 0x45314959; 0x121b34ca; 0x698f72f8; 0x79b7598e; 0x597b91b4; 0x478c0c50; 0x298810dd; 0x7a55c741; 0x15d39d50; 0x79b6686a; 0x6fe06dd6; 0x216d27fa; 0x5d71cdad; 0x02e1e6f7; 0x6055f976; 0x0477b854; 0x08cb4e67; 0x0c912f95; 0x7d015ba9; 0x17ac4ea1; 0x01f0a52e; 0x0d87ec13; 0x5049eba7; 0x61605b56; 0x4385f27d; 0x00e75dd4; 0x684e563d; 0x50fa5caf; 0x244df9cb; 0x421e740d; 0x54a3d875; 0x5a2c5f9c; 0x5b666fa8; 0x0e0b3042; 0x4c92c3c9; 0x494810c7; 0x6d48d5cc; 0x2b60ad41; 0x3a861587; 0x5236f192; 0x68a7ad18; 0x570462b7; 0x597c7693; 0x5dc3a7c3; 0x6bd51a17; 0x076979a9; 0x591bdb6b; 0x6f8ef6d3; 0x6c6fc11d; 0x43c409b6; 0x0e563262; 0x00c86b80; 0x19d39020; 0x2f561416; 0x7c7fb3e0; 0x13fe5c59; 0x7ae78655; 0x6bc7d532; 0x487bf67d; 0x0f7bb1da; 0x43cd6ef9; 0x203fdffa; 0x1ff4cd6e; 0x3d72805a; 0x1cabb100; 0x57978e79; 0x2d6697a4; 0x39207ced; 0x5b29cd55; 0x6fad54be; 0x35471293; 0x45d2fe43; 0x222faf62; 0x6041ff94; 0x4fe452e1; 0x09fb3051; 0x5b3f1735; 0x19f28b3a; 0x4969948b; 0x2bb5f504; 0x6e771990; 0x1a26d5b2; 0x01782693; 0x52c1cf7a; 0x5c9e1e0b; 0x3f46071e; 0x1b10078b; 0x321fe12e; 0x0a8f1aad; 0x50c5b3b9; 0x244a53a6; 0x26e911e7; 0x5409ca95; 0x0e562f01; 0x5b9dbb5b; 0x5103de78; 0x6c9532b9; 0x7e109d5c; 0x06df1ba6; 0x54809557; 0x0832d01a; 0x2e9d33f5; 0x441ebc69; 0x5f1a46fa; 0x4769ef99; 0x53a10634; 0x564f986f; 0x2dbe50d2; 0x0e3b263e; 0x5e4dd5f9; 0x6c6ce793; 0x3b7e7b2d; 0x6ace470e; 0x0bc364fb; 0x46567d32; 0x09d6c649; 0x713b537f; 0x115cd25d; 0x311cbccb; 0x23906d48; 0x0ee8ebe6; 0x57f8f27c; 0x4effc46e; 0x62b69f26; 0x021cfce7; 0x2f39c1dd; 0x11f3dff9; 0x31f19050; 0x3161d7be; 0x653ccb8e; 0x43ab514a; 0x58399317; 0x40b66d3a; 0x32184fd8; 0x7be92684; 0x5e144054; 0x6a020658; 0x5c6ea9e3; 0x1a0d2a42; 0x6e07b3ab; 0x192dbb0e; 0x5879ce29; 0x03c24bc9; 0x487cd04d; 0x082e47a3; 0x6256335a; 0x4628daea; 0x50b6cd01; 0x2486fc79; 0x16f9eeca; 0x216fda6b; 0x765fa687; 0x60463443; 0x629d2b6e; 0x0482ec3c; 0x5a602c5f; 0x4da8f9a4; 0x16daf805; 0x33445db9; 0x5c2c4b6c; 0x1e6ad5c0; 0x760fc9d0; 0x75054f5f; 0x7e146d0a; 0x2249fc81; 0x6b58c2b4; 0x754da041; 0x5edd1713; 0x0f53eb43; 0x0f847468; 0x45b60961; 0x35066e17; 0x2d463f9b; 0x5bff8738; 0x47fece41; 0x6b0df911; 0x2da46db3; 0x7d4df84e; 0x62524b98; 0x784689ba; 0x30d24182; 0x79f07925; 0x1a60106c; 0x358d2986; 0x590bcace; 0x2319ec0f; 0x3c203ea9; 0x17b863ad; 0x3ff12821; 0x72ab733a; 0x0a239828; 0x37f310ca; 0x1bd07b8d; 0x2c053d5d; 0x274de61c; 0x67fceabc; 0x6d64e17c; 0x696c45e8; 0x65a36849; 0x0894492c; 0x25dcbccc; 0x0c1d6062; 0x45ab99bc; 0x3abe382f; 0x123ecab8; 0x0d637cb3; 0x608dee33; 0x12519e90; 0x180a4c2c; 0x1412023f; 0x63ac36cb; 0x51c60552; 0x2ac4e2fe; 0x5ebcae69; 0x25e393f3; 0x5741f8fc; 0x672b8977; 0x5cad6441; 0x61abf1a7; 0x0303ade0; 0x66fdb790; 0x54403634; 0x386440c9; 0x5377f8ea; 0x2e811481; 0x41f9662c; 0x5b570ca7; 0x3fac5ce5; 0x7777b0a4; 0x7477d864; 0x09b0ce27; 0x65f58514; 0x5e9d1753; 0x5df4b2c7; 0x1537c09a; 0x6986f1bf; 0x72bc0272; 0x2a99a8fb; 0x42a78e20; 0x686b1a86; 0x4de3eaee; 0x1c64cfdc; 0x78255672; 0x53fbfa39; 0x6afffcdd; 0x5307a4de; 0x5b4bfe26; 0x60cb0c0b; 0x5d257dc3; 0x02ac3709; 0x1b5cd6b9; 0x6ee55460; 0x45a09f22; 0x7d08b346; 0x782699e8; 0x1ad44439; 0x152bcaed; 0x4337fcc7; 0x05d7932e; 0x71010380; 0x15b10b1b; 0x06603391; 0x3502efb4; 0x2581aa16; 0x5a3a4867; 0x7af79303; 0x63e7f7aa; 0x1bcf76f1; 0x01217932; 0x0b584102; 0x57d85778; 0x7b04b920; 0x5e7acac9; 0x69d85af9; 0x1fd3c6e7; 0x24c391ca; 0x7874e456; 0x625de14d; 0x184a85a3; 0x12d8b176; 0x629dfb70; 0x0f1eece1; 0x647aa66b; 0x0c8ef991; 0x05d4698f; 0x39bb53aa; 0x442a76b8; 0x6102de4f; 0x2d6dc958; 0x02b9e81e; 0x22def394; 0x1c63ef6f; 0x35aafbbc; 0x65a9136c; 0x4b3a6456; 0x49931bd3; 0x1891ccd7; 0x052292a4; 0x5d74f10f; 0x3f0acada; 0x410ecca6; 0x36a5b66d; 0x67e227f2; 0x5f914b7f; 0x25f7754e; 0x4fb7b36c; 0x074df71e; 0x0ff9b7d1; 0x2c5b5730; 0x19a2d443; 0x3f0cffd8; 0x25bf69d3; 0x08607eb0; 0x5c3591bf; 0x7e1c83dd; 0x3596611d; 0x344b7b7f; 0x51318748; 0x1b6bc7de; 0x3950cb93; 0x3150c3c9; 0x6c24ab7f; 0x4a835748; 0x488ff676; 0x344c9a37; 0x667b4920; 0x04705d16; 0x4aa3a93c; 0x45c12f2b; 0x0e5748f4; 0x71e3436b; 0x02d937ec; 0x77254cff; 0x65348109; 0x137ee1fc; 0x563f4c81; 0x591d8013; 0x4cb5c38f; 0x69dcae73; 0x2eea4c7f; 0x7574449e; 0x430921b2; 0x64e96ada; 0x4bfeaea8; 0x1ce3ccd1; 0x7f322d02; 0x7b3f4495; 0x56dd60f2; 0x3fe87a94; 0x460ef2a1; 0x74b24aea; 0x43910a0a; 0x2f327583; 0x521d6b68; 0x03e9a453; 0x5be1ed4f; 0x0ee37cf9; 0x2b328f8d; 0x7a30339a; 0x1085ee1a; 0x5d8f806d; 0x77528625; 0x6336b586; 0x40a45acd; 0x654ed038; 0x04f3d558; 0x0a9d1481; 0x69651f6d; 0x107b5ac2; 0x6d94fddb; 0x604126bd; 0x7c5ce529; 0x572cc18a; 0x12202a13; 0x5f4fc004; 0x55feb730; 0x5123d263; 0x7a3944b9; 0x055edcbe; 0x214e18b9; 0x5e4f8962; 0x3783d77f; 0x3ac9698e; 0x48672e1a; 0x7c67071c; 0x1b5e77e9; 0x48e40749; 0x2c30b199; 0x34740baa; 0x0ace6efb; 0x69ae7350; 0x02431088; 0x453a1936; 0x49be39e8; 0x1fd1a764; 0x2beb8364; 0x511a0ba6; 0x6c25e43e; 0x7a228cdc; 0x7efc9048; 0x6d5c3147; 0x325d87f6; 0x08ac5f8d; 0x1d1f46a2; 0x5580dbed; 0x6da9f98a; 0x12d31e07; 0x09bcc9c9; 0x16f4522d; 0x724f739a; 0x0c4ea399; 0x3a47cdc4; 0x431165ed; 0x45c5f59b; 0x64b7f58d; 0x056ff8a0; 0x1f2b9207; 0x4754c098; 0x1b29d81b; 0x6a3a2189; 0x5d6d59cd; 0x41eadbb2; 0x6955a4ee; 0x5aee1cd8; 0x702a6ac9; 0x39c38ae2; 0x68236e2e; 0x77fe3bb4; 0x5574f7f6; 0x7929bb55; 0x4c95d4bf; 0x540c36ad; 0x787cbbd2; 0x4cd8307d; 0x2f57f3f8; 0x554bad0e; 0x2744a1a2; 0x0d54c124; 0x6189b2c8; 0x714f6ea7; 0x6db51214; 0x0b9f8122; 0x5cd106bd; 0x5b2e9625; 0x0d981aa2; 0x0e6b2084; 0x4f935c8c; 0x0f4a3fc4; 0x6d7e8310; 0x3c28c81f; 0x419352ee; 0x5c6e8632; 0x55a7a369; 0x5d608669; 0x16930920; 0x383c0c9c; 0x6d78c524; 0x41b4a572; 0x05206a3a; 0x091f55c4; 0x781e8cc5; 0x73849939; 0x3069c3d6; 0x102105af; 0x4418aa9f; 0x106077c6; 0x74e3e663; 0x0bd966f0; 0x5a4e92c6; 0x11949c7f; 0x7094747e; 0x64567f58; 0x03f166fa; 0x5c1ed154; 0x6e4d51e2; 0x0f68c753; 0x6b8bce2a; 0x1f6bf7e0; 0x5da00969; 0x688983d1; 0x0f9411ea; 0x42c30c29; 0x5e6d5c3f; 0x72ee17f1; 0x5ab9c1d8; 0x7b804d18; 0x67950752; 0x567ef044; 0x2c8f32f0; 0x398aa8d3; 0x52f5682f; 0x4fd896fc; 0x2c95de24; 0x3d8b49c8; 0x0f3fb6fb; 0x3e4bd651; 0x3e1fbc15; 0x130c58e2; 0x5eb33a7b; 0x32e8c62c; 0x2db4eaed; 0x2add624b; 0x48001129; 0x0bfee6fe; 0x52795045; 0x3decda0b; 0x242ca087; 0x768b17ba; 0x27b977b4; 0x695a9796; 0x37c0d156; 0x1eae9da6; 0x20634d37; 0x591d8024; 0x3d2ea45a; 0x33a3c15a; 0x10be15f0; 0x4a251182; 0x570af148; 0x174b1e42; 0x17e0b90a; 0x033ce1b3; 0x6c6d27e3; 0x1544431e; 0x3a96b38f; 0x17937f7d; 0x2dfbb773; 0x400b4c81; 0x2ee1d467; 0x3b23808b; 0x3878c6ee; 0x2ccc3cc8; 0x43d8e836; 0x2d99a2f4; 0x48aa1ad3; 0x415cfe75; 0x0186dcc1; 0x5c5c3971; 0x28844381; 0x44879b39; 0x600df749; 0x01cbaf3b; 0x0501e48e; 0x4724e647; 0x1b94525c; 0x6cc4f0ad; 0x19ab8bce; 0x034a8a8f; 0x0d0cf0e6; 0x48d34837; 0x1bfe75cd; 0x76e6e69c; 0x28b9bf16; 0x4ccf05bb; 0x460b20e3; 0x1aab81e6; 0x22871221; 0x1bceba58; 0x3162c14f; 0x7a77fc7f; 0x6a96c008; 0x24bd9b86; 0x1eceffae; 0x71d3248a; 0x7dd7496e; 0x6079b5fb; 0x46aa4663; 0x3d94dc97; 0x2b988744; 0x13894513; 0x54ceade5; 0x51ac6700; 0x3d106301; 0x5f6ca51b; 0x1ecea974; 0x52398eb0; 0x052fd255; 0x416059c2; 0x496772e3; 0x4ba5eda5; 0x56a3c941; 0x67c7a5d8; 0x7198fda9; 0x55cdeac1; 0x28da3caf; 0x253dbf27; 0x7e7917b2; 0x61a86d89; 0x50402de9; 0x0fb8f61b; 0x2014709e; 0x2ef5cbe6; 0x445ad230; 0x23e915db; 0x266cff97; 0x69617cff; 0x00bbc4cc; 0x3abe6841; 0x4b6f7c97; 0x1763cc8a; 0x50cade99; 0x1e161de1; 0x7ccfcd96; 0x6606f768; 0x70484358; 0x759d61eb; 0x0cdfbbbc; 0x44e51f9b; 0x555b6bbe; 0x31809e0d; 0x7611c864; 0x0d2d06e8; 0x79daa60a; 0x075cd420; 0x52976c7c; 0x60fd8034; 0x79576a57; 0x56643e64; 0x10fd1ba7; 0x34a29206; 0x1280e3be; 0x2b102cac; 0x1de9c81a; 0x624ebbac; 0x015cb1bd; 0x2bf6865d; 0x49e6b9d9; 0x1dc0fa2d; 0x282867a4; 0x23880f57; 0x49480b6c; 0x1453c615; 0x254f2d3d; 0x3fade2c4; 0x1d484333; 0x3b7ad09d; 0x241e0c3f; 0x3f6bce27; 0x3a266bd8; 0x5c16a2c8; 0x2efc228a; 0x0171f038; 0x2df99611; 0x2d9f7cc3; 0x6607604d; 0x2a339b56; 0x56451520; 0x064c5792; 0x005f8733; 0x014186ba; 0x2c453eec; 0x5b4c16bc; 0x166a91d9; 0x3d6a1867; 0x4a9f32a0; 0x04992e7f; 0x5f25c7d1; 0x059c19da; 0x6050625c; 0x528f5dc5; 0x5aa7dae0; 0x09c76d57; 0x1719c27b; 0x5fb89917; 0x7d7e1a63; 0x7132108b; 0x1b07e3dc; 0x3be9c866; 0x677d3f98; 0x31dc4c07; 0x4681afde; 0x7f8593fc; 0x08a73130; 0x1510c9b1; 0x00fd5082; 0x7b19afa1; 0x3d48c17f; 0x5d809454; 0x60607809; 0x2f32d01a; 0x5d2d79d9; 0x7358f349; 0x328de67b; 0x2783c512; 0x219128b8; 0x5d6895ab; 0x6100781e; 0x1401caf2; 0x57d88484; 0x77ec205f; 0x09615075; 0x6fcede45; 0x6ccc9133; 0x58b1da70; 0x0c62d9f3; 0x2fb2802a; 0x50b2767e; 0x14070e83; 0x366ff9a2; 0x08e33e81; 0x5a7501f2; 0x6297cb91; 0x2b736f71; 0x4d2a6dbc; 0x11cbe4ac; 0x6796c025; 0x6696e255; 0x1a7db249; 0x05b7a730; 0x1a564e20; 0x51396ea3; 0x476de965; 0x6ef27926; 0x72036c29; 0x14af38ef; 0x42a0bec5; 0x02b9f243; 0x0914df62; 0x0a5f3eb8; 0x4c295107; 0x66bf8d61; 0x7bd10745; 0x46996fb2; 0x09f0744d; 0x52b6d2c4; 0x047baaaa; 0x7793d0f2; 0x7bce7e8c; 0x2ceb5f22; 0x69a768bf; 0x041b2743; 0x12b1134f; 0x1b614c4f; 0x50d0ad7f; 0x61aaf852; 0x31b19398; 0x3cd568f5; 0x7aff4e9a; 0x01be839b; 0x15e70b51; 0x4ddc10cc; 0x41ac7cc6; 0x32278de9; 0x7c297ffa; 0x538b5777; 0x2f654e22; 0x206fc727; 0x36b61615; 0x3083f758; 0x0a5ff376; 0x50e83ac5; 0x298f5119; 0x1be5047d; 0x4cacacba; 0x15729437; 0x30bffe29; 0x796454bc; 0x464164c5; 0x6e1b52a4; 0x34a197b1; 0x2f6de3e4; 0x33ec8cf0; 0x7689183a; 0x25494ffd; 0x3c2e08b1; 0x52aa9539; 0x202225e6; 0x48c9c982; 0x104b069a; 0x5bd3d6eb; 0x2a31eb11; 0x3f0ebf0f; 0x5db7a5b9; 0x032e26b9; 0x7ce94a74; 0x1de43949; 0x60283bca; 0x446326a0; 0x182fec6c; 0x5d482618; 0x24a8136b; 0x16b82f35; 0x35dd65bf; 0x3cdb68d0; 0x6fa2feff; 0x64f25d36; 0x714f7b92; 0x6474293c; 0x438b3310; 0x38f1d054; 0x1c7cbe18; 0x6557eb33; 0x44f6f003; 0x001da352; 0x4d42f5b1; 0x26a86a29; 0x587aa516; 0x21d2d6cc; 0x5ddedcd4; 0x04b27318; 0x3f1ddec5; 0x0ba998cc; 0x6fa3526b; 0x317ca40b; 0x64046062; 0x2b988fe4; 0x4d0ca215; 0x49293924; 0x4aec68d1; 0x46987709; 0x224d68cd; 0x01da0c8c; 0x640ab4ad; 0x2a0fde34; 0x258ff50d; 0x66cdf960; 0x0115127f; 0x31337e3c; 0x1f0c97ed; 0x431c7f85; 0x7420e6be; 0x1503d04f; 0x266164cb; 0x34c41bca; 0x76ee24e8; 0x053c829a; 0x6919bd42; 0x470eecb2; 0x19e34d6b; 0x1c3410ff; 0x78f1ce94; 0x002fa2d9; 0x148043e1; 0x1bd1b14e; 0x7a730d54; 0x2268f97f; 0x265c3cd4; 0x035ab6ef; 0x5636dde3; 0x4b8ce2e7; 0x089993dd; 0x07d33f78; 0x47a06853; 0x08818463; 0x4d4d5a43; 0x3d984089; 0x34048502; 0x710b3345; 0x7dd0b5cf; 0x4c1e989b; 0x223669f4; 0x191f26ac; 0x06d7c58d; 0x4d3804c7; 0x58e5fad3; 0x12acb23c; 0x3fb31889; 0x53530ba7; 0x187f836e; 0x565d5fd1; 0x75916085; 0x78cfee7d; 0x50d3414a; 0x4b08da32; 0x62b6b757; 0x22403cce; 0x31555807; 0x64b730e0; 0x2782f7ac; 0x68c2d1f0; 0x03d8b1fb; 0x71ba690c; 0x13358eba; 0x289a8d55; 0x44451f4b; 0x4aaa7397; 0x6e8df8dc; 0x5cc51ef8; 0x62ba14a0; 0x55247932; 0x1cb2c617; 0x38c4279a; 0x3e3fdb1d; 0x7923d01a; 0x48b5a0da; 0x2ded66c5; 0x55d8bde2; 0x30e0f1b5; 0x0ef8ee5b; 0x26499f32; 0x59e46eea; 0x203238ae; 0x317d94be; 0x22b66c78; 0x3d77c3e2; 0x3dbb7d80; 0x37d4cc3c; 0x3513c89f; 0x652c1aa5; 0x3e45f397; 0x18952cb9; 0x715d715b; 0x5818afe4; 0x1b2c8936; 0x721b42a9; 0x3806eab6; 0x373fb803; 0x65cf04e6; 0x60158639; 0x229fa6c7; 0x4ba93161; 0x45883ed7; 0x6acc130b; 0x292e1ba1; 0x7e32eb03; 0x28d74880; 0x6918953e; 0x02e9e610; 0x7ecf2cd2; 0x055965b5; 0x1be309f7; 0x1a349a09; 0x50004d81; 0x3e142878; 0x4c8fc307; 0x5b624ed3; 0x6a206d54; 0x511daea3; 0x28e07141; 0x76effaab; 0x3fb9e092; 0x56599aaf; 0x47c1a9f7; 0x43ba2dd6; 0x76f6b718; 0x057227ba; 0x1d102f2d; 0x78950bf6; 0x354ed3ac; 0x6bb6949b; 0x1ac6de9c; 0x70fd18b2; 0x24f64dab; 0x7abbe85b; 0x4b59634a; 0x457f3101; 0x69d0c293; 0x5f4b3b3a; 0x64b41643; 0x091603bc; 0x53aca769; 0x06540870; 0x32206888; 0x0c8ddb7c; 0x65a2fe9e; 0x6ae56c5d; 0x35bc174a; 0x0e19faaa; 0x6d968f8a; 0x0c255585; 0x70729843; 0x6eb4bfbc; 0x096ccfec; 0x4283f5d3; 0x18dbc0bb; 0x0b8bd4d8; 0x3c7bc5d8; 0x36511e62; 0x3fcf9fcb; 0x5863f9e1; 0x0c93a134; 0x3868cb81; 0x09bd7098; 0x4d6c4d3a; 0x743aa681; 0x452b22f1; 0x73110ba0; 0x30bab914; 0x482d48f4; 0x39aebe41; 0x4335e085; 0x437220b0; 0x784cd569; 0x451cb08d; 0x35e65220; 0x5a5923c5; 0x23ea7282; 0x5b5ce8f6; 0x60a4b66f; 0x004d4f86; 0x0a0da666; 0x23afa782; 0x41843bd0; 0x66e3c594; 0x09f01fff; 0x759e0327; 0x19c0d86a; 0x6b45d72f; 0x1c030b2c; 0x1dcd8a65; 0x6bfbabca; 0x17605f56; 0x7e2f0134; 0x1b34fba5; 0x650f3665; 0x3d96ae27; 0x59c19804; 0x3068e28a; 0x3f570a23; 0x435466c9; 0x5defe5b1; 0x2b2b2868; 0x5420bbe5; 0x0d71526b; 0x7ed008cb; 0x404884f4; 0x2a1f25cb; 0x1b08266c; 0x6e3ab543; 0x39f5159e; 0x7f71867e; 0x0af9051f; 0x11cbee38; 0x13efcd0b; 0x02320a8e; 0x67d2c7f1; 0x5ebca7e9; 0x55f5fbfc; 0x3c7e1f48; 0x2e49d4c6; 0x1d4ea021; 0x48976b2d; 0x162b5749; 0x30a48718; 0x4df5ccb5; 0x4483dc7e; 0x495cc6a3; 0x47e774d7; 0x33a166ea; 0x6c320c7e; 0x4ea77f68; 0x28f2a560; 0x2a8eb1b8; 0x4b2caa11; 0x76a4b342; 0x7ea97d2c; 0x60149381; 0x3ffd3034; 0x0b5d8676; 0x2ed5dad2; 0x16e0f9bc; 0x53337770; 0x5fc683e4; 0x6160eb15; 0x1a60fbb8; 0x75512e2c; 0x74485660; 0x24bbd3b7; 0x72e49a59; 0x67fac082; 0x696d6f1e; 0x5210a35c; 0x3da4a2df; 0x026ae1db; 0x15a79c6a; 0x2b4cd21c; 0x2b624148; 0x61c25d04; 0x55496f5d; 0x558722ad; 0x2a1273fb; 0x290e1223; 0x037c391e; 0x39d83696; 0x02301f08; 0x46e728de; 0x7c19a28d; 0x331e1641; 0x2c8cc04f; 0x0317cb2f; 0x0bb5cb0e; 0x3c494b88; 0x7ad14516; 0x46670386; 0x35cd8c27; 0x347493c4; 0x65c121af; 0x5a5af777; 0x24ec5406; 0x4efb1d22; 0x0706f58b; 0x1ec08da3; 0x477e8577; 0x75e2b792; 0x6380f73b; 0x659dbbf4; 0x3c3d238c; 0x36149d5d; 0x7d803b71; 0x613eeaf4; 0x4a0eb13d; 0x66935032; 0x5e34fc6d; 0x7f5e0e88; 0x6b58b524; 0x08e6c626; 0x13d7d6ab; 0x24b13685; 0x16ccaa95; 0x30f916c1; 0x4d9b9d66; 0x362fa441; 0x42d7cfc3; 0x68fef43e; 0x0767accc; 0x0c9adb6d; 0x64294a9b; 0x7de30f35; 0x0107a9eb; 0x51f769ba; 0x1ba83ee3; 0x43ab802a; 0x5c8e6383; 0x597f9fe2; 0x01a76dfd; 0x71920459; 0x50dd63d1; 0x221243f9; 0x4c0daca6; 0x0f3dddf0; 0x7d1e3b58; 0x1a6b1765; 0x6b3e0df2; 0x2f96ef48; 0x15d27e9b; 0x430fbf95; 0x21a38f7b; 0x77b096e8; 0x438799a8; 0x77c4e8ab; 0x37e67c07; 0x7e0daa9a; 0x731a1cff; 0x15cc30d4; 0x738101a0; 0x472e465c; 0x5a9350a5; 0x56de970b; 0x10b61cbb; 0x005cd8b0; 0x103b68f3; 0x3668b959; 0x1738935d; 0x14427f04; 0x573cdf89; 0x00291429; 0x48a290c9; 0x7ec02ac9; 0x0b8f3442; 0x115573ed; 0x2d68388f; 0x08ad0c10; 0x1bcdaf7d; 0x307fb7a5; 0x47711635; 0x79cb7e95; 0x2d95f62f; 0x5e1002b6; 0x30a6d954; 0x538f91f6; 0x29a90194; 0x3ea7ca32; 0x27139830; 0x5fff5777; 0x3294e1c6; 0x1ff8aff2; 0x25271b4a; 0x6e81606b; 0x1c20f54d; 0x443c10d6; 0x71a68314; 0x405df3c7; 0x01e035c0; 0x20af781f; 0x69a5a459; 0x47e41335; 0x5b96e3b5; 0x5e6cf1f2; 0x6af6bb79; 0x354816a1; 0x54483619; 0x5e77e838; 0x36ff7b1d; 0x003d365e; 0x065217d6; 0x3c3c0a43; 0x16399e3d; 0x10fc0ecc; 0x54706771; 0x11f8b664; 0x6beb65ed; 0x5b67f0f0; 0x1a5104af; 0x016c6ed5; 0x2b64b40e; 0x21d7666b; 0x40182bee; 0x4150d06a; 0x0fa97fe1; 0x7e249e7a; 0x3a903dfc; 0x7a58a20a; 0x5413b746; 0x52282b47; 0x5bd7770e; 0x6b7d2b6c; 0x0fdbec2b; 0x24a73ca0; 0x6b0ed62b; 0x2dc7bed2; 0x7cd08546; 0x58cbb358; 0x115a485c; 0x0593a84c; 0x7d245728; 0x7e705081; 0x35ba77b9; 0x77eb1ff8; 0x390ed226; 0x5b746195; 0x7a2f46ca; 0x173c2f51; 0x7f5ff48e; 0x0e5e0c24; 0x26885263; 0x539e6af3; 0x4975bf07; 0x737ec724; 0x378c8526; 0x0548525b; 0x1e6aa7de; 0x3d3e23ca; 0x1bee9c7e; 0x459fdcc4; 0x168a4e12; 0x300b753e; 0x224e3486; 0x18aaa7af; 0x240edda5; 0x6b1ce7c7; 0x39e54fc4; 0x68c0d007; 0x60a1237a; 0x060af98e; 0x1c664afd; 0x60191e88; 0x5008ca70; 0x0729d4ea; 0x7af0fea1; 0x3e567b36; 0x636e2b36; 0x6991ccde; 0x4e970d41; 0x7f4a23d4; 0x61ae9b21; 0x519c859b; 0x64755291; 0x6c821ce0; 0x6c092357; 0x58d1d605; 0x643fdb00; 0x7af9d488; 0x78b375e4; 0x5c1b5fed; 0x19737d40; 0x25ca92f2; 0x484e53c3; 0x32de5364; 0x67aca2f1; 0x348f85eb; 0x7bf18db4; 0x1e808be1; 0x27f8037d; 0x303ec858; 0x148276f9; 0x783b394c; 0x549d9591; 0x7b903dfa; 0x7c744ec6; 0x48e33110; 0x355061b0; 0x2e9433e3; 0x4f7d56e5; 0x266002ad; 0x349a2de8; 0x453d6d97; 0x19e2d185; 0x06b439d2; 0x4e6d973e; 0x5acd66d4; 0x47e4bb2e; 0x0ffd3fd8; 0x33792f6b; 0x7b4dda07; 0x58b28d85; 0x42976852; 0x660be05d; 0x2f6daa6b; 0x443310de; 0x3a8593a7; 0x343815d6; 0x65cb403e; 0x15f39284; 0x0eb91fed; 0x71b11b1e; 0x7ee61aec; 0x7b2361c4; 0x0c80d611; 0x2d06e291; 0x7aa1b1fa; 0x3fc08590; 0x22dc6056; 0x190bc4b5; 0x3071efe8; 0x2936bb08; 0x626654bf; 0x1a6a59ef; 0x4f39fd61; 0x6423b9f3; 0x25ae2918; 0x3649275a; 0x2bb09ddd; 0x146c8d63; 0x01d7052c; 0x5700ffe5; 0x02195656; 0x491c1747; 0x332ccff2; 0x7b047ab4; 0x1cd7cff6; 0x610f9463; 0x7d3626e7; 0x3ccab87c; 0x4056307b; 0x71652f78; 0x5026ecf1; 0x4cb33171; 0x1c2346ea; 0x46a481f8; 0x2442e434; 0x272369d0; 0x178f0114; 0x2528634e; 0x7e601305; 0x5213ab95; 0x7aca98dd; 0x03a1f86b; 0x179b39fe; 0x638fdf4c; 0x6e187033; 0x427d6e27; 0x7424600e; 0x686883bb; 0x43245a8f; 0x0c67e7fc; 0x07ecca7b; 0x70d66cb9; 0x4b66d2ef; 0x50c96ebd; 0x7abd1121; 0x3b652ef4; 0x27b6181f; 0x04835d8a; 0x006db332; 0x5c67fb8f; 0x2ef4823f; 0x2262f538; 0x79352f1e; 0x3dd506e1; 0x0e697922; 0x4398c0e3; 0x17614e94; 0x42329b31; 0x1891be3f; 0x38876db4; 0x60c2645a; 0x297d710b; 0x4eaf2588; 0x633c61de; 0x0e3ec224; 0x2b0f367f; 0x5783cd9b; 0x3012db44; 0x0dad035e; 0x75862c6b; 0x18a6a9e4; 0x457d54b8; 0x0cfbbfc1; 0x626d0948; 0x1a11609a; 0x52db0720; 0x0d2e9949; 0x73592db9; 0x0836c12e; 0x01a3ca36; 0x4eff3899; 0x54b688e2; 0x77cfd704; 0x0d16b76a; 0x39ce0419; 0x123ca410; 0x3feaac4e; 0x5ffd2dbe; 0x7e5604cd; 0x7591dbcb; 0x4596e87b; 0x026d7e8d; 0x28ca14de; 0x17b18e89; 0x31935812; 0x4d23f884; 0x15a1e507; 0x0e62eed6; 0x399b6464; 0x3dad0b13; 0x53c8a326; 0x5697042c; 0x78718a8b; 0x6b8a6385; 0x383878b3; 0x5f65a31d; 0x43903e76; 0x5199544e; 0x79d5f067; 0x7bb7271b; 0x68d23870; 0x3a753b5f; 0x18ff32dc; 0x0668a4d1; 0x1ee33a88; 0x1622a4d4; 0x3ccb06a2; 0x75a9daa8; 0x344b0695; 0x25b2f982; 0x06b309c2; 0x6124d76d; 0x1f8566a2; 0x446e5001; 0x3fbb65c2; 0x666f84bc; 0x029cc5d4; 0x06fef632; 0x3b1f652d; 0x2313b502; 0x51aa196a; 0x3becdbed; 0x77b388df; 0x5824fe17; 0x4f2bc8d9; 0x0b7e2cb5; 0x0211418f; 0x4be80c5c; 0x6f598410; 0x01d70361; 0x3ef9cd78; 0x56e8a46d; 0x33f249ef; 0x708375da; 0x10232b3e; 0x1bf28dc1; 0x7f248535; 0x70b11739; 0x703a6f57; 0x0a7d8ac4; 0x4366fb05; 0x3570ce08; 0x6399d401; 0x523eb476; 0x6c9dc7e6; 0x1fe20c02; 0x5349e6e3; 0x5683a0ed; 0x4f45860a; 0x21b9c950; 0x38b4c90a; 0x122a63c4; 0x00dcadc7; 0x5c685fc9; 0x579d4124; 0x742d8c77; 0x5d890bf0; 0x472af297; 0x6524ca78; 0x2d85b3f4; 0x0661a51a; 0x2fc4c6ad; 0x0f732de0; 0x3f7db076; 0x25654f96; 0x32dfcc7b; 0x5cff18f6; 0x51d24ec7; 0x3a849f02; 0x2d8cd529; 0x348a155f; 0x128ac16c; 0x51b2bfa3; 0x2f3742c6; 0x6d6dee68; 0x3e1780e5; 0x71430228; 0x57be94a9; 0x649de755; 0x1dedc43a; 0x46dccc41; 0x029ecc67; 0x0eda761a; 0x03f0b658; 0x23c73c16; 0x15e0a3b6; 0x7424f1e7; 0x6b2b752e; 0x25ee3cfe; 0x163b63b3; 0x39455fc4; 0x5cf9ac67; 0x56f72a60; 0x0fdeb5c2; 0x11337b7c; 0x75580a63; 0x6ef3223f; 0x3530b515; 0x60e52142; 0x40a0c952; 0x75ee0856; 0x46859913; 0x73b0e9be; 0x1fc694ec; 0x6df120aa; 0x4d21a11c; 0x1778b9d5; 0x6b5ce9de; 0x31c6e7d4; 0x20b75a04; 0x28079b69; 0x2a017d5b; 0x75b8dc56; 0x131cae15; 0x2b744638; 0x0b13383a; 0x48941fa6; 0x408fa934; 0x523b8aa7; 0x2c64c822; 0x386abe53; 0x5a5c8e4e; 0x1ff099f1; 0x5a9d146f; 0x43735120; 0x0ba80217; 0x5d830ad8; 0x77dd1e3b; 0x6417a535; 0x3f9f1757; 0x3cbce2b9; 0x7df926ee; 0x3d47799b; 0x736acbe8; 0x3e2b902d; 0x21b3f03f; 0x3fd3b242; 0x5cbc2690; 0x1aa2d70e; 0x7a898e86; 0x2b2aeff9; 0x05fc5fa0; 0x688709bf; 0x2029696a; 0x6f2b92db; 0x69c593fb; 0x32887339; 0x46b5c7ee; 0x01c7adef; 0x6c2c1d80; 0x4dc496b3; 0x439d5df7; 0x056a9c2c; 0x452faabc; 0x4b5cf188; 0x14c30e37; 0x51d9a1ee; 0x32850029; 0x74b38012; 0x22c37992; 0x3eded38a; 0x13f31ecf; 0x1b0c45de; 0x282ba3b0; 0x7d1a6816; 0x0a37ebaa; 0x4eb98141; 0x155bd048; 0x6909adee; 0x7c60985d; 0x38b9986a; 0x25376392; 0x22468a80; 0x597bb549; 0x2c907676; 0x5b789d12; 0x1c09c2ca; 0x2ace1417; 0x0f309694; 0x1be1622a; 0x4d303e18; 0x52f5cf6d; 0x75268055; 0x399b4ccb; 0x3a438c99; 0x3e2e9ff4; 0x472d2559; 0x2e179f04; 0x029d0266; 0x4e4187ac; 0x7602c4f2; 0x3b015ab9; 0x0ec8ca63; 0x64f334fe; 0x2fcda2cc; 0x55d36bd7; 0x55b8f6dd; 0x6e8afb12; 0x1519cd67; 0x6bb80efd; 0x0c487762; 0x4c11ff13; 0x5f06a508; 0x706c098a; 0x51b16212; 0x736f8ed2; 0x0a77d16b; 0x6f8a2069; 0x5a0aa0d6; 0x7379f199; 0x47df978a; 0x41f66f74; 0x33b3f10a; 0x326d3e81; 0x4cad3f0a; 0x4a7ea929; 0x1744d250; 0x0e57925f; 0x2fbdd887; 0x228a587d; 0x795ab273; 0x5d524715; 0x35e405a4; 0x3c5d1502; 0x34375ada; 0x24284551; 0x2d7b8657; 0x2f6895b4; 0x5e3ccd6e; 0x021b67ea; 0x05a0b1fe; 0x219af52e; 0x7a68af79; 0x7dbe4b05; 0x10609660; 0x1716ca9c; 0x44c4c4de; 0x0c76fc6f; 0x6bee144c; 0x7e2f247c; 0x70e27c80; 0x246a8e8d; 0x1d8a1923; 0x1332ef7f; 0x15623c32; 0x7b12aca5; 0x1ff63a96; 0x21ad6d66; 0x3f7c14bd; 0x3c47833a; 0x2fbb3aa9; 0x4319e180; 0x2b52c07f; 0x27faf754; 0x5e1d447e; 0x475b7bbb; 0x078f8db8; 0x775b81f9; 0x61c33237; 0x1f1eb3cd; 0x013f98b6; 0x72c234b7; 0x3499c3c1; 0x1508aeea; 0x45fc1b80; 0x6e7656d1; 0x6e465c79; 0x02421332; 0x18d05641; 0x03b461a8; 0x2069c886; 0x6dd1d1fd; 0x4e2eb486; 0x267d6b90; 0x70a73a9d; 0x485ba502; 0x513b8e12; 0x04cde3bd; 0x1b5842d5; 0x59f4839b; 0x00baf57b; 0x4fd0a7cd; 0x5dcec214; 0x476c94b1; 0x24b49a8f; 0x02345c07; 0x70bf90a6; 0x4263c388; 0x2bc09fa9; 0x67920475; 0x102db6de; 0x49477a59; 0x0d6bca31; 0x765d5c6d; 0x7641defc; 0x2382f738; 0x5f2d3847; 0x0813dad3; 0x36110f2b; 0x5a0d70cb; 0x5a820c56; 0x2ab100d3; 0x314cc0b3; 0x10a63ea1; 0x21afc203; 0x1af7f635; 0x523cadd3; 0x5848faac; 0x2009b1a4; 0x28edf346; 0x0e076f39; 0x40dd1dfc; 0x19454d7e; 0x536499e1; 0x4cfe66a5; 0x740eec2d; 0x4389c1d1; 0x3b480d8f; 0x559fe63e; 0x3aa95d86; 0x02b063f1; 0x226d9525; 0x3a8939c9; 0x20822a33; 0x17b7deae; 0x1374633e; 0x42f5c1e7; 0x2ee28717; 0x07bc5581; 0x12fb5ff1; 0x0fc33713; 0x6835fba6; 0x34194bd0; 0x32f0c720; 0x52a22dc5; 0x275e1a4f; 0x398788ae; 0x73552ec8; 0x0ccd1589; 0x0b565dfa; 0x45a85700; 0x33dfdd95; 0x6804b8ff; 0x15e0bc31; 0x0edf3044; 0x56c23414; 0x2a904a5d; 0x0ff824f2; 0x3803521e; 0x38c96075; 0x418bafd5; 0x0b1751bf; 0x50de1f84; 0x1243e3ce; 0x4142a3bb; 0x6bf5acd0; 0x4a98b49b; 0x17c380d7; 0x10eabb7f; 0x2e211ee9; 0x43559895; 0x120f8fe5; 0x41444c79; 0x556ed854; 0x1e77d791; 0x6784a7c2; 0x49d63651; 0x61406b8c; 0x3eec4ed1; 0x2046aab6; 0x135f339e; 0x5ff8d5ce; 0x45c31cae; 0x0fd112b3; 0x7bfe394b; 0x45815dd0; 0x2740b5b9; 0x34583ab6; 0x6e16793a; 0x4476575a; 0x655bc32a; 0x5e8a512e; 0x2d69f885; 0x1a5df686; 0x3b8ef85c; 0x46f4866b; 0x3b91267a; 0x2b224b1e; 0x7cdf7a3e; 0x1d30f22a; 0x4b7906db; 0x691afbe5; 0x4a81220e; 0x19b2cb5d; 0x003ccfe1; 0x60aa8e47; 0x2e80e827; 0x00c10c0e; 0x7290e823; 0x3ab9193e; 0x59018e01; 0x091f1369; 0x29457a4a; 0x1cb22871; 0x5eaa7421; 0x7d60120a; 0x2c5dc1d5; 0x221d0cbc; 0x7dcfc197; 0x41f27b22; 0x42e081cd; 0x40f58eca; 0x0e329ebb; 0x2b02fbb5; 0x38eb6398; 0x1d302dee; 0x144bfab6; 0x47b45d2d; 0x0afc5794; 0x4f7d7450; 0x77b637dc; 0x2f352f4f; 0x47aa8c6d; 0x192ee6f5; 0x54edb9e6; 0x5ad955dd; 0x21bf10bb; 0x7882522d; 0x4ff3105b; 0x0e003402; 0x3914db07; 0x07206f09; 0x192bd68b; 0x48e097d6; 0x7f738d03; 0x3548f239; 0x1f556559; 0x5a120699; 0x1de212c4; 0x44327121; 0x729735d7; 0x1df93727; 0x6f30bf2e; 0x3582bbba; 0x2cfbdfc7; 0x762ebe19; 0x23b295e3; 0x2a45a0b6; 0x42adfcec; 0x7467b349; 0x3bb6db6d; 0x4f1b9159; 0x52971f27; 0x78e4f308; 0x72bb223e; 0x6eaeb9dd; 0x41c75b76; 0x43075843; 0x5f705c31; 0x18a40dc7; 0x483408f9; 0x67737627; 0x66e6f6f0; 0x6db5e1a0; 0x628b50c9; 0x5e498778; 0x3e8504ad; 0x0ef8a5c5; 0x322e8288; 0x2850987d; 0x34bfd531; 0x09476c01; 0x0d800fb3; 0x00b31b4e; 0x7b08d065; 0x3cc13245; 0x478aa452; 0x558307dc; 0x7ebdd476; 0x4ed7ebe5; 0x563856c7; 0x7c06186d; 0x1b5a46a4; 0x3c2eab23; 0x2e597499; 0x2cce345b; 0x646da30b; 0x7207882b; 0x0e69b01b; 0x79425667; 0x10aa8aaa; 0x420028f0; 0x548d5c62; 0x1acc1c75; 0x66150147; 0x25c6bbcd; 0x323eb521; 0x19b69fed; 0x74968c5c; 0x45226a9f; 0x57e49b04; 0x37798ef2; 0x4314898a; 0x4ba3a806; 0x243fa728; 0x4f195e5d; 0x725318ee; 0x0b5d4099; 0x40e0ab73; 0x4eff963c; 0x57150ce5; 0x10d4eb59; 0x4359dc39; 0x73f97336; 0x7f73a89d; 0x0f31589a; 0x15788eab; 0x0fc34a01; 0x0f98c3fe; 0x5ab7a35f; 0x12fe6e3d; 0x1d34aee1; 0x475a20ab; 0x05301b81; 0x3731b197; 0x141b061d; 0x02038eda; 0x3b2cf5a3; 0x22e8062b; 0x1ff7ba7f; 0x5fd38a7d; 0x4644f9f6; 0x0718efae; 0x0f62d3f8; 0x7fc2f703; 0x7df801c0; 0x0423e00f; 0x5fcb8116; 0x311c0a60; 0x2157315d; 0x05faed90; 0x5c6cacb3; 0x32ce6062; 0x795d50ba; 0x2a2331f4; 0x670dc594; 0x2b05a2cc; 0x1958b6d5; 0x155a60f5; 0x21f0024a; 0x0e1159f7; 0x070d4827; 0x5e7a9944; 0x4ffd9be4; 0x3fb2a1db; 0x5a519d74; 0x2b645342; 0x5f5fde78; 0x5728a0f0; 0x4b2177fe; 0x091bd43c; 0x6999e5f6; 0x2056f645; 0x1a5fb634; 0x209f36ea; 0x50082395; 0x5663153d; 0x63808836; 0x13e1be53; 0x4efc5721; 0x269c0fca; 0x6bf2ad30; 0x02b2e99a; 0x5f2657b4; 0x014c218d; 0x3e1a5eb1; 0x210d8e95; 0x3b32dbf5; 0x2b6f19f6; 0x048a909a; 0x389fce76; 0x57048b12; 0x4b7c6d43; 0x363ede02; 0x41249b9a; 0x2fc0a4f2; 0x31625d9f; 0x747ea635; 0x128b3a0e; 0x4700b3e2; 0x147fa1ca; 0x6449adcb; 0x6be45a59; 0x688c43ee; 0x78ef5fdd; 0x3916622f; 0x03a4bb73; 0x3682c7e9; 0x371ab2d6; 0x5e87cefb; 0x2c0bb950; 0x1c14de12; 0x607b2f61; 0x58fb476f; 0x5aa034fb; 0x76e509a0; 0x6d6a2508; 0x02e8d7c7; 0x6458a188; 0x1b8c7be8; 0x09a7683c; 0x2fd349ec; 0x7630c840; 0x78fc6ac5; 0x75119dd2; 0x6e792bcd; 0x5e9b52f8; 0x1b16de3f; 0x4fcd7094; 0x05aef895; 0x700ff99e; 0x20aa071c; 0x0fb4254f; 0x0db6fb1c; 0x220d58de; 0x75391864; 0x58d59542; 0x7e4d0dab; 0x70cc4e3a; 0x0e2f2725; 0x5c5fd8cc; 0x7b3e3697; 0x62b63527; 0x4efc96f6; 0x3f03c88b; 0x02bfdb72; 0x30248715; 0x5b6285e3; 0x5201d939; 0x34c35303; 0x65310694; 0x519fa01c; 0x2839e9b5; 0x769b0f9e; 0x251ff9a0; 0x306103e4; 0x6cc53cba; 0x2d530753; 0x6c98e796; 0x2fd26a6b; 0x2027f625; 0x5ec0e015; 0x5f2fbd3d; 0x36b6a8e5; 0x208dff84; 0x55667420; 0x4b169192; 0x59d85160; 0x396783ab; 0x6b74b81d; 0x0740d9cf; 0x7de70e9a; 0x27b915d4; 0x4e2d92d9; 0x3b2e071e; 0x0cc2be38; 0x32334433; 0x341533aa; 0x5d59ad71; 0x148ab82a; 0x0add2d85; 0x291d958f; 0x5fee44e2; 0x3e814418; 0x1ab8fb28; 0x17f8565a; 0x3494e690; 0x642fe314; 0x4ea48a20; 0x4fce7b04; 0x7dc3232b; 0x0c838263; 0x578bb576; 0x38701f33; 0x0b0a68c0; 0x71da5caf; 0x1986bfd9; 0x319e7547; 0x1380b906; 0x103d8ac2; 0x33f4fd52; 0x614fe53e; 0x0fea2e1a; 0x67183781; 0x0ac0ec59; 0x3caa98fa; 0x38bec575; 0x05b18411; 0x07e457e5; 0x19ecb3a2; 0x2a1a3af5; 0x0d7f9046; 0x76ff3352; 0x63510636; 0x204ea078; 0x7b237053; 0x7f96c11a; 0x4785af01; 0x4dc92c50; 0x70ed7853; 0x7d4b5e2f; 0x4b5d3cd1; 0x497486e5; 0x6813b8c2; 0x3e8d6ed9; 0x70b8825f; 0x71438e6d; 0x450c64b5; 0x5ad4d93a; 0x3fac9f4f; 0x5436658f; 0x226f4066; 0x27b96a68; 0x5e87a5bf; 0x581afb62; 0x7414a28d; 0x70b32220; 0x13d3d7bc; 0x5d93920a; 0x305941f1; 0x1958afbe; 0x285604d8; 0x783a3146; 0x6c5cf513; 0x76599d8a; 0x288377cd; 0x3ff643b3; 0x43d6dada; 0x0919e8ba; 0x7b9a6fa2; 0x0e145ed2; 0x522a6e86; 0x7b6f40fc; 0x4b612a69; 0x2a21e223; 0x302e9211; 0x16065716; 0x37ee58d3; 0x4c5237a4; 0x6ebca315; 0x35a3a4f6; 0x647d4526; 0x75c7c5e5; 0x2662e8f2; 0x68cfc39c; 0x7f141e8c; 0x7f3d59b2; 0x713009ce; 0x3cfd65e2; 0x6d920399; 0x5df441da; 0x329a880c; 0x58b0d566; 0x2025e86a; 0x5a599e7d; 0x59f7a6b5; 0x5bb520b8; 0x112dd707; 0x646e40ad; 0x15c53f46; 0x16ddd3f6; 0x41772d65; 0x4d5063b5; 0x5ea895db; 0x4b7f922f; 0x60040783; 0x2b6decbf; 0x4f2155e5; 0x0ebff517; 0x035eff40; 0x26d9e612; 0x2399883a; 0x440fcc24; 0x4cd2ab2c; 0x61348a3e; 0x72e1b0df; 0x5f59bd5e; 0x151ffc78; 0x5d3737d1; 0x6808108c; 0x5fc2bac0; 0x163cca42; 0x370e9bdb; 0x416c5ff2; 0x4751d730; 0x275d9319; 0x3afe320e; 0x5c4e9af4; 0x273d0d9f; 0x6df37842; 0x3b1bb279; 0x1a70c968; 0x5ccaccdd; 0x5b11e53e; 0x6f09ab90; 0x33306bcc; 0x755ccc3b; 0x2d69f110; 0x45ce1ee4; 0x55b3560f; 0x4b61cfa4; 0x4c86edcf; 0x37a63fd6; 0x7b89f077; 0x065fbc2f; 0x55dc5de6; 0x12416326; 0x1e6dd589; 0x6816c403; 0x1edb61c3; 0x0d7eb97b; 0x0e14e002; 0x7087d1bd; 0x1474bd1e; 0x728abe4f; 0x3875af57; 0x1a3e2433; 0x38aafecc; 0x1165fa66; 0x6e1f2b77; 0x34df02db; 0x34c5ace6; 0x16d21bd2; 0x2a576193; 0x50e01de9; 0x4f4c2042; 0x28ccd193; 0x0118b0a8; 0x2d1e1194; 0x0b186e1b; 0x591b6182; 0x5b1669a3; 0x3dc87988; 0x4155ad19; 0x0b7da189; 0x5d66a048; 0x1b8ffa9d; 0x3d9ab968; 0x215e567f; 0x4fcc1d06; 0x3ecd0eda; 0x2b096b5b; 0x4b0e6ba8; 0x5d9941de; 0x24d44c38; 0x2815a91f; 0x12f4ffef; 0x4eb8a212; 0x338e301c; 0x7c080c07; 0x24b00562; 0x1bd4920e; 0x383cf62e; 0x48564f90; 0x587a971c; 0x39bfcf07; 0x4fd05db8; 0x29cc58c5; 0x21a5c4ea; 0x553b0b81; 0x0aee1786; 0x6b0db236; 0x3afc25df; 0x41e03234; 0x77191114; 0x6cc3c2d8; 0x0aa3edfc; 0x099265e5; 0x132ab3fd; 0x72fbabb7; 0x7c520d2f; 0x29217994; 0x5f50abbe; 0x240f8680; 0x4d42cf9a; 0x274f34ab; 0x61dfe105; 0x36ac1134; 0x7b135c87; 0x086fa1ae; 0x5f251fff; 0x52bffc95; 0x78ef3d0f; 0x7f3319fa; 0x78cb6ae4; 0x6235bc0e; 0x0884d04a; 0x1f488ebb; 0x228dd756; 0x417faca3; 0x1b602e81; 0x34edf07d; 0x2cbc229f; 0x5af39841; 0x07f861b7; 0x7d7497d6; 0x2daedfd4; 0x43eda3ed; 0x5c715918; 0x5e4bd046; 0x405413a1; 0x3ebe920d; 0x6bfe6632; 0x13e7759b; 0x11007468; 0x59275594; 0x0b500dc8; 0x1c720f77; 0x49774070; 0x3d71707c; 0x23e1afa9; 0x1afaca8b; 0x24c4a16b; 0x605ba779; 0x59abca85; 0x537d1bd0; 0x41625cd7; 0x34f14a62; 0x6a706b97; 0x0dfa68ab; 0x5354be5c; 0x01f76c34; 0x74e97d1d; 0x56803b57; 0x01b6d6b1; 0x7baa3355; 0x5af3a463; 0x394eb382; 0x7d3a52a9; 0x1ce19b11; 0x13da49a4; 0x3330f7cb; 0x39947b74; 0x380fef57; 0x67ac0697; 0x725e425e; 0x52069f4c; 0x5a91ca8c; 0x2c89989c; 0x270e7de1; 0x39e940ca; 0x467147c7; 0x02f161dc; 0x1cc1c7af; 0x5870717a; 0x5a4841a6; 0x29b97166; 0x2155c4bf; 0x0fb22b7f; 0x30ebaf33; 0x75572e79; 0x71995cdf; 0x635dc4f1; 0x47223f92; 0x7c1160be; 0x42c9e6f4; 0x65d93ca4; 0x5cb4b3cc; 0x59f452fd; 0x184cf6d2; 0x0c29661c; 0x3c302af7; 0x427eb6e5; 0x73647e5f; 0x72fb07ab; 0x3f4fd2b6; 0x33285d8a; 0x071426dc; 0x69bf1112; 0x4e8d1254; 0x5716e046; 0x3ebdaad9; 0x15bdcdf4; 0x4d5afbe9; 0x41c4891c; 0x7635ab8f; 0x066d1c1a; 0x082ef13e; 0x3cdcfc51; 0x2e462b1c; 0x7855f1b0; 0x6496bb72; 0x01157f67; 0x54f7a611; 0x62ca0f98; 0x4864d6e5; 0x78f4ff3f; 0x1941e5f8; 0x22ffc525; 0x76d259dd; 0x7b2db048; 0x2c46ddae; 0x50fce5c8; 0x47e92e97; 0x6e5a3e1d; 0x20383925; 0x7623cd15; 0x42542320; 0x65269620; 0x4227b7dc; 0x6fca8347; 0x2b4ac80f; 0x287e7607; 0x2356dd26; 0x53141027; 0x3da0576c; 0x4dfcedc9; 0x38cf58f2; 0x3ac5337d; 0x4e091bc2; 0x62771f1c; 0x3022c185; 0x67be0e90; 0x20cbb7d5; 0x49e2e0c7; 0x4163191d; 0x0d619edb; 0x1d62e802; 0x7cfe0882; 0x303d09e7; 0x6efab1d2; 0x07f7b2f0; 0x0c5168ec; 0x48db4cf0; 0x47cf41b8; 0x41d12d22; 0x596dae08; 0x70225e74; 0x205d878c; 0x403d2c15; 0x1d84a46e; 0x74edbda1; 0x22d550fb; 0x09330dcd; 0x369f48ec; 0x01ef6b42; 0x02ffb8d3; 0x236cfc79; 0x5838b102; 0x3baed070; 0x2019d2c4; 0x40b28871; 0x0421ae21; 0x0e4a8cb3; 0x17f9a913; 0x576b1e6d; 0x0323e2e8; 0x36e74609; 0x094b0597; 0x75c1ab66; 0x389e3214; 0x150b3fd6; 0x6c1480fb; 0x4758b86f; 0x45fc6e63; 0x7c36a108; 0x2c9417bb; 0x20796197; 0x3dd882a4; 0x5dd2c328; 0x447a6d63; 0x1d50d626; 0x68a53e91; 0x687b34ec; 0x297c784a; 0x17c15b30; 0x3eaf2496; 0x03fcd529; 0x111db78a; 0x1bc78587; 0x73b98903; 0x5124c094; 0x0317085f; 0x22d73489; 0x6f0a0d7d; 0x4a3ea284; 0x72b3e3c1; 0x45540042; 0x2f1aff15; 0x1184de83; 0x44efcf99; 0x100f10eb; 0x0a60989f; 0x393d3243; 0x5c69e55c; 0x0f053ae1; 0x1c36e3ad; 0x08220d7f; 0x18eccf5b; 0x6956238f; 0x43009e99; 0x3eb6846c; 0x3ba8d2fc; 0x72176e61; 0x58f2b1c3; 0x4f09b0ef; 0x4076272b; 0x0269c653; 0x6a750af3; 0x74f73602; 0x68f0404a; 0x64554782; 0x3bbd5eb3; 0x7a3b8098; 0x70f70d13; 0x03767dfe; 0x7bcd3d70; 0x78c464b4; 0x5c1df256; 0x4b0f0b32; 0x0142017f; 0x5afaf3d9; 0x7b34abc7; 0x3d305635; 0x0b3e6c87; 0x7ed8ce87; 0x526bb7d4; 0x0866e015; 0x0cf6bb75; 0x5d619a5e; 0x7dd19740; 0x11951079; 0x4b7015b9; 0x73c60eed; 0x59bf64da; 0x4c139246; 0x06bce054; 0x552c2027; 0x76498f60; 0x1716a8e1; 0x00bc683c; 0x0bc4d2c3; 0x38dfb361; 0x5290432e; 0x3533a783; 0x2b034708; 0x13dc6bf1; 0x67adb4df; 0x454c1c6c; 0x7fa89e01; 0x66d75d01; 0x318cc638; 0x5c176262; 0x007a5160; 0x55b1eb82; 0x36061fef; 0x4683bc01; 0x3bcb2864; 0x394e4d7d; 0x1bffb5ae; 0x3c33af44; 0x253641ba; 0x76359470; 0x52f351d2; 0x37f0ce3a; 0x715b4006; 0x509867fc; 0x3ec1b864; 0x0c189992; 0x73719dbc; 0x0f004be8; 0x2f731c15; 0x3b9de5d6; 0x4a9728ff; 0x29e41425; 0x791b4b80; 0x5b78b814; 0x695ab9e0; 0x55c50a32; 0x53c1bbd3; 0x74386af5; 0x65f3ab2f; 0x6b167e16; 0x61191927; 0x10d36ee7; 0x714c72d7; 0x486f1761; 0x508cb2b0; 0x5b118765; 0x7546714d; 0x7795161d; 0x16f1ad1c; 0x40d72d51; 0x138ac72a; 0x71c1c32a; 0x09ca3bc2; 0x40c607ca; 0x60667159; 0x151bd20e; 0x3f16109e; 0x7f49a924; 0x2caff0d4; 0x698a402f; 0x468590cf; 0x3c719bbe; 0x00228d4b; 0x7febf49f; 0x61ee0a75; 0x6321506f; 0x7e5a5ea7; 0x1690b8ed; 0x7d7fe897; 0x6fb83917; 0x1610c69d; 0x469be633; 0x05878167; 0x77d2e01e; 0x140a18e5; 0x3c7d25f1; 0x14d06d1f; 0x402cf8aa; 0x781e28ba; 0x3c5d3330; 0x26751668; 0x04fbfd67; 0x41d6587d; 0x7850179e; 0x51b7ef33; 0x27752dbc; 0x799b69c9; 0x1af81a9e; 0x0fb7a7f4; 0x4ab85598; 0x09d68c8b; 0x0b939aab; 0x4752a963; 0x1b900522; 0x3efc8779; 0x4fac56ae; 0x2aaf8789; 0x74e8d409; 0x35f9d081; 0x036ee442; 0x05999340; 0x5b67e77a; 0x08062ba7; 0x29a208d5; 0x52a95082; 0x38d3d953; 0x5b3c66cd; 0x6f593ef2; 0x471ff614; 0x28a60777; 0x6b55f098; 0x05fb5359; 0x7324cf10; 0x064465ee; 0x7b107ea3; 0x1963cd39; 0x5ab248e3; 0x282ba636; 0x551e4b2a; 0x714c1e7c; 0x6587c6b4; 0x5e73045a; 0x78bdc91c; 0x78e0ba73; 0x2298d184; 0x1ba9c9a1; 0x6ac60d43; 0x27812021; 0x3ffe2d17; 0x094593a6; 0x7de3404d; 0x757fe17c; 0x5d952ee2; 0x5776a4ae; 0x361a1673; 0x104ee7ab; 0x1502c4d3; 0x74de8a10; 0x58e7e8b9; 0x26a5b231; 0x59ce3889; 0x7629a6c2; 0x4464cb5d; 0x1afb39b9; 0x0afa2a10; 0x031a6122; 0x2b5e7c50; 0x79d65f90; 0x5abfbac1; 0x4a6fbc57; 0x0cde04bf; 0x0bfde841; 0x3ff2dff9; 0x1ee54dd1; 0x0a65bcc6; 0x62e15e0b; 0x122dc57b; 0x09b29d86; 0x20cf6d34; 0x0a5811dd; 0x0dadcc4e; 0x5f818b00; 0x20ca4cc3; 0x5c444f38; 0x0a4e0e63; 0x1638e084; 0x5ec26021; 0x06d2c5ba; 0x04ea3064; 0x65638c12; 0x1e833e0d; 0x0e5d320d; 0x49b44952; 0x3ee119d6; 0x6e7199ab; 0x6424104a; 0x61306969; 0x7819999b; 0x171a568a; 0x797f1323; 0x2d94e279; 0x21a50a1e; 0x02d62334; 0x0fc63b20; 0x718fc024; 0x578d864e; 0x064affbd; 0x50b68ff5; 0x7c4a4af6; 0x24319292; 0x602f25c2; 0x07a8557d; 0x3ad7bc40; 0x505ee2a3; 0x3f20e2ef; 0x7c529cf1; 0x3015a272; 0x1be8807d; 0x665a9077; 0x270ff78b; 0x2b764596; 0x763c0fb1; 0x6650c8bd; 0x1d9b2cc4; 0x5ecb33ae; 0x0a6724da; 0x36fe2e6a; 0x7a285123; 0x394717d8; 0x14047f9f; 0x6268a2d8; 0x07ec7113; 0x04799ec6; 0x5ff7cd9a; 0x024d8545; 0x14308a4f; 0x20e7d1e1; 0x5ee6e563; 0x1c6fdae8; 0x1946b79c; 0x26b2387a; 0x2a11cb55; 0x444c27c9; 0x69d8fe95; 0x4c611d51; 0x0816479c; 0x38ad41f8; 0x5660def2; 0x6fdca975; 0x1b96c41d; 0x36441937; 0x36fd6ccc; 0x4ee7f8d6; 0x15dbf2c8; 0x4395bec3; 0x382111dd; 0x71e67925; 0x7351f44e; 0x1068cdbe; 0x4cdbcc4c; 0x43b26fa2; 0x0c895704; 0x6ced025d; 0x3bc0ae25; 0x4afb8f9b; 0x584613ef; 0x0777010d; 0x1e462994; 0x58d451eb; 0x387a8662; 0x251ed2fd; 0x236b9150; 0x1d0197b7; 0x3f4acf93; 0x2014a7b5; 0x103273e6; 0x60304388; 0x41774766; 0x36729bb9; 0x48431b97; 0x03f653d7; 0x22d3c70f; 0x5d880568; 0x1034119a; 0x3ac53697; 0x7598cc9e; 0x7b2c0d6f; 0x01606ffe; 0x65ea5131; 0x3940dde1; 0x53015da3; 0x4153764a; 0x72e1c1bc; 0x7ebeb43b; 0x3c10cb7f; 0x486fbacc; 0x4ff3a299; 0x2b777abb; 0x5cf9813c; 0x6843ced2; 0x1c9cbc25; 0x4d299ffa; 0x0d4367e5; 0x78bb112e; 0x54eed40c; 0x77d674f1; 0x20dbd271; 0x58e10a25; 0x3124802b; 0x4aaf56dd; 0x04c34d25; 0x1f96398b; 0x7b1af1db; 0x63df030a; 0x2b8c7ae1; 0x286f42de; 0x6627820d; 0x42cf7172; 0x5c7c0ca8; 0x7389adcc; 0x643890f5; 0x36a6dc0d; 0x3eb800f4; 0x7a31883f; 0x4e9c2f98; 0x6e9080a5; 0x263297ae; 0x3336f207; 0x4cae2aa7; 0x633082b9; 0x32f8e18b; 0x1f7dc004; 0x4ec4d4af; 0x092fd3dd; 0x3164eb5e; 0x5d685a75; 0x32e3944d; 0x56e20ff6; 0x007b50fd; 0x2c2118fc; 0x5ad84c43; 0x3d17990c; 0x6872712f; 0x45f9607f; 0x03ea6eec; 0x72d85d67; 0x139f72aa; 0x760c19e5; 0x34885dd0; 0x4252850d; 0x1a0da774; 0x52e9369c; 0x1a1dd232; 0x6ccf489e; 0x009e1096; 0x46ced2a1; 0x3ba12484; 0x5c21425d; 0x34f5a7a3; 0x385d748a; 0x28b29065; 0x4d8271e0; 0x1a2c9876; 0x3bf8c431; 0x31eb8f45; 0x2f77fad7; 0x5ca16376; 0x526ef6a3; 0x5aa366af; 0x6a2c574c; 0x49d91d38; 0x03581d3b; 0x5e24d7fc; 0x69cdd94e; 0x5d0b41b3; 0x0ed36ab3; 0x1bc8b563; 0x03d9d18a; 0x66713396; 0x45e5d08c; 0x7e0d9017; 0x50eaf619; 0x00d7576f; 0x08a636e1; 0x0af0b667; 0x6613e753; 0x546a94a6; 0x43ad9c23; 0x7c4d9143; 0x1c81bc26; 0x6fbe92b6; 0x1e851e23; 0x05bcc05b; 0x011b872d; 0x615cbcf1; 0x6e36b962; 0x33d4af29; 0x64b23d7e; 0x63fa8191; 0x688ba7e2; 0x64b68c20; 0x667f0a0c; 0x3df65c9a; 0x6c6f6308; 0x697cc6bf; 0x16947a5c; 0x339b9d79; 0x71a473e4; 0x0a670cbd; 0x041e1e18; 0x4a8fcf6b; 0x7e5a1cc2; 0x06db51a2; 0x430c2c36; 0x26efe2d5; 0x392b1192; 0x4944f7cb; 0x57925973; 0x5354e955; 0x78101f3a; 0x5d7acf71; 0x111eb3cc; 0x67b2e0fe; 0x4cb639b9; 0x34c731c5; 0x359669e3; 0x7be3d5a5; 0x2b255d76; 0x6dd9bc91; 0x37b134a8; 0x4023f2de; 0x29010e92; 0x7f2e73e9; 0x4554253f; 0x55db9b84; 0x6e1fb800; 0x4d7c486f; 0x00c95b8e; 0x02fbbb08; 0x37bd54b4; 0x4d4c466c; 0x03326852; 0x6f1c57f4; 0x650f5828; 0x257bc0ed; 0x59d563a7; 0x39cf6e30; 0x77ed0220; 0x74072c80; 0x4ce4d321; 0x1e3b6b3b; 0x11b7cbe7; 0x00b58f25; 0x1fe92642; 0x5d88b299; 0x74804042; 0x6e6294c3; 0x213a7157; 0x49868796; 0x1c00e2ff; 0x4ab648ca; 0x5255d948; 0x10e59486; 0x3c62c097; 0x1e38337a; 0x432a7712; 0x749e9f34; 0x286ee75f; 0x491070cb; 0x547702e5; 0x4f087ec0; 0x7512c0e1; 0x6a74ebc1; 0x3850161e; 0x40ef2da9; 0x4d415d52; 0x49260f3d; 0x36c63884; 0x0c9965d7; 0x00d4cea3; 0x575c11b7; 0x38b779be; 0x6cb263e4; 0x25aed54a; 0x3cca9230; 0x0f394190; 0x38a43bb4; 0x3a7df307; 0x2f75f3c8; 0x4535cd1a; 0x263373e3; 0x087c86f4; 0x4e6fc23a; 0x7615bdef; 0x7aba8e43; 0x39ab54d3; 0x78938889; 0x0c8994eb; 0x161d551e; 0x1feb13cb; 0x6fa7235e; 0x7842e8dc; 0x5be265fb; 0x3dc1bbd8; 0x2b42dd8b; 0x035c2fa0; 0x6c5bfd71; 0x6fb03d70; 0x5997ffb2; 0x22799227; 0x549eea90; 0x63ad4ef2; 0x4e193331; 0x2048283b; 0x0a0f9bc2; 0x40333317; 0x6c2d81e9; 0x38086dfb; 0x00b4f714; 0x576d2546; 0x53e24182; 0x081f2198; 0x53454457; 0x348b6001; 0x34da3a3d; 0x437b3e05; 0x3cc656f2; 0x4824b0b7; 0x4f82fef9; 0x7774a615; 0x59f42d36; 0x1e874dff; 0x75923161; 0x3d4d19cd; 0x1fdd6839; 0x2d85417c; 0x0668f243; 0x66943d31; 0x2f6893a1; 0x66d4a308; 0x4809c375; 0x1dddb6aa; 0x11283c04; 0x5f3f4031; 0x25946ece; 0x610345ee; 0x46571018; 0x4af0b0ab; 0x2a4656cb; 0x6a0ed0aa; 0x3ca5d22c; 0x05fa722c; 0x08687b89; 0x1deb2bc8; 0x2cbcbb12; 0x32ea36c9; 0x335aa1cb; 0x4d432e3c; 0x58590325; 0x6528ba15; 0x7a8502d7; 0x5eddf67f; 0x05c7f2f9; 0x55c44f6e; 0x60eff105; 0x4e653ddf; 0x52443246; 0x6d6c2302; 0x1d407d23; 0x385bb9f5; 0x76bb9251; 0x467748a6; 0x4f7598b9; 0x03951874; 0x1ce29e87; 0x29f981be; 0x656475e8; 0x77e577bc; 0x38b592d4; 0x64bc9138; 0x1ce0e8cc; 0x5cc0dee4; 0x7bed28df; 0x7d4b833e; 0x372538eb; 0x54f9ab5b; 0x60219684; 0x5edd67dd; 0x4152a814; 0x2a17dab3; 0x795c87e1; 0x0318f771; 0x69212f49; 0x5ffc8f3c; 0x31b6efac; 0x0ddc5b0e; 0x59f2e97e; 0x77e19587; 0x702388ad; 0x0fd80d57; 0x56481a14; 0x24798f46; 0x0e7cddcb; 0x7f5e87d5; 0x6b7f8044; 0x720a8827; 0x5dce12a9; 0x37b27ab3; 0x3f85d2fd; 0x35bd5f1b; 0x28f31600; 0x6926167d; 0x0c92a104; 0x79d44637; 0x40b00545; 0x364d1499; 0x4f973b47; 0x2707a4a9; 0x0fffef9d; 0x62e9f1b0; 0x1ccdb9a7; 0x0b269175; 0x41988ee1; 0x6b019c43; 0x7c6a7660; 0x7fe50937; 0x2cf76d4f; 0x48a41b5b; 0x675ab10c; 0x3269e641; 0x508df653; 0x25400cba; 0x01ae510d; 0x2abd4152; 0x7d5a624d; 0x18216fbb; 0x0404a3a4; 0x202d1f84; 0x257531b7; 0x4358f8ee; 0x07cbca2c; 0x25d14f6d; 0x52eb267e; 0x20dc0c7c; 0x188d0058; 0x415d8702; 0x30ad0167; 0x6fd805b2; 0x24efd4c4; 0x55d804a6; 0x63e75f27; 0x6f76851d; 0x1b04ff6c; 0x2914369a; 0x26854920; 0x0d382bf2; 0x384f3fa6; 0x3a6e77b8; 0x5c91624d; 0x158280df; 0x18ebf672; 0x67944eaf; 0x473fb56a; 0x4d627d87; 0x2240cf0c; 0x27dfee23; 0x6871444c; 0x4769f7b3; 0x6ac7a64c; 0x4813975a; 0x321345e2; 0x7a654917; 0x00f2af9a; 0x6b7b4c8f; 0x4387212d; 0x29989b35; 0x62a22337; 0x4d91eeae; 0x7457b82c; 0x18f8e953; 0x78517e81; 0x131ae695; 0x48fd27e2; 0x15776b81; 0x02658de4; 0x042c331c; 0x361cf324; 0x5136c5ab; 0x1af02f55; 0x3f782342; 0x22e67f36; 0x2eee0c0b; 0x75d5214b; 0x7497be44; 0x750711a7; 0x43c429e0; 0x66f25e7f; 0x3ab7b867; 0x4bb98074; 0x2110fc81; 0x7e9b9a25; 0x2ccabb7c; 0x3cca79d3; 0x191683b3; 0x681287c5; 0x172312a8; 0x5a8ac1a4; 0x776faa04; 0x75d0373b; 0x2baa1086; 0x3a708f00; 0x677f6df8; 0x19bb4d47; 0x03551e77; 0x004ec921; 0x3e197549; 0x3bbff427; 0x23f33763; 0x02b04e5e; 0x34303c5a; 0x571ecc5e; 0x361ae0cd; 0x579d66fa; 0x3c0f23e5; 0x328119d6; 0x2acd416b; 0x118d3785; 0x34e5f9a9; 0x1e97e844; 0x267728ed; 0x404665fd; 0x4eb07439; 0x3c3e0e3e; 0x47f30741; 0x0c2a8105; 0x5f821242; 0x6a886e36; 0x4b060219; 0x7c033fc5; 0x6d8e88e7; 0x743facfe; 0x1311fb48; 0x4b1d6b5a; 0x61c9e8f9; 0x247acfac; 0x6eebe842; 0x3a50620c; 0x6ba34d82; 0x61d707d9; 0x7a28073c; 0x6f3018bc; 0x125edbf6; 0x600c6170; 0x1fa675df; 0x04052be2; 0x5cfd2fb6; 0x010b46d6; 0x7c6b88af; 0x42c44e47; 0x3239873d; 0x6d55a8e4; 0x68d33f97; 0x59dd1f03; 0x3a1cd62f; 0x71413ee9; 0x0e04b8bc; 0x3fa9de50; 0x1bfb9860; 0x1d320046; 0x0d5c5393; 0x1974b193; 0x20f9789e; 0x58512422; 0x029c6c03; 0x306d2867; 0x6bfa436e; 0x4b8194a3; 0x1f2ea268; 0x30493c41; 0x394ccebc; 0x7f02ebf1; 0x2869c79d; 0x5ba3c913; 0x522f913c; 0x135e0005; 0x317f53c2; 0x10ae0831; 0x2d1fb996; 0x47527af5; 0x73347852; 0x3059f561; 0x736ac6ef; 0x245b55b5; 0x0aa92dca; 0x31468e40; 0x72c505ad; 0x5c75ccf4; 0x6e6a958c; 0x71f6fdcf; 0x19d71bc2; 0x46cd9367; 0x55d27242; 0x00fc95cd; 0x59e4d26f; 0x6e13cda8; 0x7a0b8045; 0x149715b8; 0x1c44d762; 0x5d241a53; 0x35633056; 0x4e6bf0fc; 0x371b31d7; 0x125e4978; 0x2b31a480; 0x2cce79eb; 0x74365b5f; 0x0e61a254; 0x1b7667ff; 0x2e13c5e2; 0x21d18d30; 0x0dca0f44; 0x3c2d4239; 0x72674960; 0x43572e2e; 0x1653b074; 0x67cd9cb2; 0x26997999; 0x284ca5a3; 0x45445635; 0x408a0fd7; 0x1182bec5; 0x3908bc9f; 0x654aa774; 0x750525bf; 0x3935d809; 0x16503333; 0x12850179; 0x3bbe8863; 0x0fcff8e9; 0x477ee5a8; 0x57112c2d; 0x7f692857; 0x5dd1fec4; 0x007535b1; 0x70e5a633; 0x38abdc8f; 0x794b02da; 0x7c4e0ea5; 0x5c162e99; 0x2e6b7e2c; 0x150a36a8; 0x224a1db7; 0x310308fb; 0x758ca33c; 0x28ad8864; 0x5c270857; 0x21451b86; 0x1fc6b1e7; 0x231cd080; 0x40c3518b; 0x6bd07585; 0x274185b2; 0x499f9e12; 0x39c6fedf; 0x67f01bf1; 0x341821c9; 0x405f1855; 0x08f10b1b; 0x5f5f0262; 0x7f14fee8; 0x314b130b; 0x4e87295b; 0x47b49179; 0x2eccaf5c; 0x142aa4cd; 0x44f779b8; 0x09fb922c; 0x05c93179; 0x52efc022; 0x19ef07b2; 0x6de67c68; 0x7c4aa130; 0x75a1c155; 0x0eb4c80a; 0x2c25ae21; 0x18d20df4; 0x3e7935a8; 0x11e9546b; 0x25537b53; 0x737910b3; 0x7f8dae88; 0x6076f39e; 0x28288087; 0x1b678118; 0x7078f694; 0x010aca41; 0x09b15eb2; 0x6a1ca66f; 0x024f8085; 0x6b00405d; 0x7c4f0753; 0x3a111ddf; 0x03dcaa86; 0x3bd5c6e7; 0x6240a6f3; 0x6c69c44e; 0x786c4cbc; 0x7d8c61a8; 0x716b6fe9; 0x51c27d60; 0x2450553a; 0x7e333184; 0x49dd2551; 0x6ba8a2cf; 0x5b486e61; 0x0f3121c0; 0x0cc694fe; 0x7628f6ad; 0x556211d7; 0x3e46d924; 0x6ce479fb; 0x3ca445df; 0x6142a947; 0x6a5a91f3; 0x44a51ebb; 0x33c35391; 0x4d8175a3; 0x2fbb5cd2; 0x60ddf645; 0x060a9171; 0x59ec5f80; 0x0b3b392f; 0x134dba9d; 0x342f281f; 0x4c535e20; 0x26f41f77; 0x477a4d16; 0x5a5b9810; 0x20ae0d21; 0x7e0ccb41; 0x535de6db; 0x7ab3e2eb; 0x13b8c347; 0x5175a15c; 0x57538688; 0x0a25008a; 0x009ee4de; 0x4e2d4aa4; 0x2a159a8d; 0x3ab4eee7; 0x791419cc; 0x1072bc3e; 0x4f1b9e62; 0x41dd7ae2; 0x44f993fb; 0x12ff1efe; 0x3c4afe27; 0x767576da; 0x1c176ee5; 0x7d310e21; 0x61415445; 0x6e37b73d; 0x2482517f; 0x15868c3e; 0x04daf8ab; 0x7ca27925; 0x39536577; 0x46185d24; 0x5a114757; 0x530a511f; 0x274130fd; 0x145e22f1; 0x258655cf; 0x7023c88b; 0x6ffba3f5; 0x3118f256; 0x75ee4160; 0x6e985e61; 0x6729cdf7; 0x62294668; 0x6e38abde; 0x3f47f6f0; 0x44bb2221; 0x050e166e; 0x7c1deea5; 0x5e8e9293; 0x03ab5438; 0x05e99c3f; 0x27dc38c6; 0x69217abd; 0x67c6c5d0; 0x306eeba1; 0x151f12e9; 0x10fdc3a9; 0x43001a1e; 0x403cb6a0; 0x1c759bae; 0x739ff519; 0x18a2a2c0; 0x77b62a26; 0x101dc187; 0x7259aa8a; 0x053f6d7d; 0x75cdf6d0; 0x34954961; 0x43c53d1e; 0x2f19d30b; 0x31cb4386; 0x448c7574; 0x2b7d8cda; 0x43b17ae2; 0x6ed3a3e3; 0x662006ac; 0x048c5a87; 0x50f77cd3; 0x59adf484; 0x04b82a8e; 0x0601786a; 0x69a80da7; 0x030b1305; 0x7f224b91; 0x554d6561; 0x0872fb31; 0x32439cab; 0x6cfca818; 0x7e2e85d1; 0x1e237db8; 0x6b6eab85; 0x2c03a9a2; 0x056ce66f; 0x15ec2004; 0x4c6334cf; 0x4fb34228; 0x2816a584; 0x0e4adfba; 0x470dce06; 0x74cc8552; 0x78634d90; 0x672ac1f9; 0x2646f8e7; 0x7487b232; 0x3d72f037; 0x7798df83; 0x0068ccb4; 0x7867cb0f; 0x70ee0e84; 0x535d3313; 0x2fef1f7f; 0x597c7553; 0x627aa78a; 0x1fcaf9d8; 0x20d1eef7; 0x5f21e7db; 0x57bed229; 0x453c3383; 0x6c182950; 0x1ba95018; 0x49446cad; 0x6d2ef17b; 0x0b839ab0; 0x635f584e; 0x4aec70e7; 0x172f3e69; 0x01c62d6a; 0x4ff4cdfb; 0x4481cadf; 0x265880c9; 0x63ea1aec; 0x17c9d8a3; 0x33901052; 0x4a2720fe; 0x286cae78; 0x2c5b6d69; 0x4650f75e; 0x10205a46; 0x1f20ce1e; 0x649a139c; 0x74f7c9a0; 0x407ededf; 0x12cc23a0; 0x59d3c025; 0x64f49735; 0x456d56c9; 0x1baefcaa; 0x188edc9b; 0x360aecc1; 0x722232bd; 0x367882d2; 0x32e35078; 0x2e469dfc; 0x05401320; 0x4c524d2d; 0x5d0ae680; 0x75e7503b; 0x29cc2d30; 0x1e71f7ee; 0x25549c64; 0x4bf6eed3; 0x17ae6dfe; 0x73022635; 0x0efccb06; 0x50b87ac7; 0x3c46da68; 0x55b2ef85; 0x7d33dc30; 0x650d6431; 0x3daea8ad; 0x5b447185; 0x447d03e9; 0x657385e1; 0x6d8a45da; 0x49f595be; 0x78cd8b86; 0x706abf47; 0x71451883; 0x7fc7794e; 0x391f364e; 0x0a0bbe4f; 0x6eca65ec; 0x6963fabd; 0x6ce7b44a; 0x76c4c01d; 0x6584f0d2; 0x4c216813; 0x08f2e72f; 0x1ad03236; 0x1f77adce; 0x1a6922cf; 0x59f39dca; 0x393e7956; 0x06331fa7; 0x4e77374a; 0x15519851; 0x12d3f1e0; 0x351f674a; 0x44cf4d16; 0x4ef3af8e; 0x7d011e33; 0x01db9e9c; 0x567f44c1; 0x1a8b8075; 0x4f73fad5; 0x13d57e07; 0x3ae94922; 0x710a944a; 0x6813cd59; 0x1ffc0cfd; 0x5fb9230f; 0x7999c2b5; 0x78c3cfdc; 0x784c7b75; 0x025f4b50; 0x62df5793; 0x578bdead; 0x39e87c28; 0x1fdf4ccc; 0x44cd69e9; 0x105fd1ca; 0x019f50c2; 0x60eadeb4; 0x5bf3b694; 0x4eacf638; 0x70c4f46e; 0x733e5315; 0x29ecb4b4; 0x4d876f1b; 0x57846793; 0x402a0c6e; 0x6e8c1b7d; 0x4e023932; 0x2013ad66; 0x57427635; 0x77a4dfe3; 0x31f6f215; 0x22e0261b; 0x2b76ccc8; 0x3e7f1ce7; 0x3d4eb95c; 0x1e2c3b97; 0x3693750b; 0x2b516ad7; 0x22618ad3; 0x2007c505; 0x6d2253fb; 0x53e2b3d2; 0x2658f508; 0x14f15526; 0x156961c1; 0x5bd9aef5; 0x17fe663f; 0x13b5801f; 0x2645bb43; 0x5bfc0896; 0x39b3ee37; 0x1882e0ae; 0x5494d6cb; 0x4f231480; 0x4f81b4b4; 0x4c6b8bcc; 0x2a80a5fc; 0x0fc2863c; 0x7d0f5a9a; 0x12d391db; 0x63c62cae; 0x6dcd1abd; 0x56d756d2; 0x5ad69ec7; 0x733316f3; 0x5d174dc0; 0x2b638370; 0x0791a88f; 0x3394a67f; 0x3b25e223; 0x54bfeab0; 0x4eede88b; 0x2e4f18e1; 0x10a0cb69; 0x48bd6474; 0x142dba5c; 0x3c1fb91d; 0x20913df0; 0x4f222a10; 0x7eea83fa; 0x143d9787; 0x234276eb; 0x21943fd8; 0x7afcf61a; 0x37cfc701; 0x0e91d3b8; 0x32bdd0ac; 0x2673b2b1; 0x4f8080aa; 0x5a433931; 0x76272a40; 0x3be388d0; 0x4f138b43; 0x44c8cc46; 0x755e4526; 0x7d9bd3ef; 0x655b571e; 0x4a2701cf; 0x606f42cd; 0x1a9ed0ab; 0x205da39e; 0x79ee468e; 0x42f18e3c; 0x00e6e10a; 0x07594beb; 0x11ae0e7c; 0x6d130ff2; 0x6307d6f5; 0x65192e54; 0x3101acf1; 0x00948478; 0x55d579d3; 0x5c02b3bd; 0x00ddadb1; 0x7402b81f; 0x5d86c02f; 0x61f95db2; 0x68c9131d; 0x225cd412; 0x06ed9363; 0x0d171887; 0x0787ca99; 0x6e4720f4; 0x0b75bc96; 0x2a4c6f55; 0x0b731847; 0x65f47295; 0x697973a6; 0x57d6ed42; 0x44e32a0c; 0x05df6ab1; 0x30ef124a; 0x4cdc50b5; 0x02a7b795; 0x48b89f58; 0x5a1e9b4e; 0x0c1b9f86; 0x4853d297; 0x3b8bc64d; 0x4951ba00; 0x42f16a2e; 0x7d635dee; 0x2f56ada7; 0x30bfd935; 0x575b1150; 0x54b60754; 0x28d04c1e; 0x1d24695b; 0x35684121; 0x19bda0b5; 0x5f0d06fb; 0x3bcc3882; 0x56cf48ba; 0x2d9d19c7; 0x7a8ed977; 0x09804603; 0x21e2f1d6; 0x7e025120; 0x4c067df4; 0x6bf24efb; 0x1dccf27e; 0x1587fded; 0x5520cf64; 0x22248ac8; 0x29e8c1f9; 0x6b201f69; 0x68ddcb5f; 0x35d6efcd; 0x1d8be27a; 0x385f2231; 0x2faabb67; 0x2c15d7b7; 0x1ad06b4c; 0x63ab8f52; 0x58cbcb88; 0x22eddd1b; 0x47c19e57; 0x325caf00; 0x3d838f8a; 0x51798027; 0x24783165; 0x030a63e9; 0x7381a5a8; 0x0da2c319; 0x5152e6fc; 0x2ddc4572; 0x5606b7a4; 0x47957e28; 0x0c28840c; 0x510ba632; 0x6244bc12; 0x5fec5509; 0x6978068c; 0x1f27ba34; 0x7d6bf406; 0x0b479ad0; 0x46d34493; 0x6a7a1924; 0x54e33d90; 0x013a999a; 0x27133934; 0x73d9f31c; 0x2c8ad76a; 0x35dc746a; 0x1bf24116; 0x067e7042; 0x63bad7d5; 0x16261475; 0x04e9e8cd; 0x7779d1d8; 0x6ccc682f; 0x32312028; 0x49c9917d; 0x1d5fd4ad; 0x196391bd; 0x6a38825e; 0x12435a0d; 0x2f975905; 0x48c69a32; 0x22d1d253; 0x369008bd; 0x790bcf13; 0x3257fc0d; 0x0f14e48d; 0x6c80d52b; 0x1a95edb9; 0x4c2d8230; 0x3459618c; 0x78d6d034; 0x6f425b82; 0x2b56daa7; 0x09a4965c; 0x4738e054; 0x55550a95; 0x291e7b11; 0x4a725acb; 0x454bee1e; 0x2ad76572; 0x22f2da13; 0x6a3f6e38; 0x4fd6f0a3; 0x0120446f; 0x0d532e8e; 0x135969d9; 0x30281a2f; 0x1237160a; 0x5fc81d86; 0x4a0efb08; 0x05fcc265; 0x0c71fc77; 0x023020ef; 0x5fbcd58e; 0x500b9501; 0x46fb6317; 0x505b51bf; 0x70ebc1a3; 0x3cb9a5ef; 0x4bd3e511; 0x284c87da; 0x5d531a40; 0x220d9231; 0x0c7c857f; 0x5733fad1; 0x2666f33d; 0x6ea64545; 0x66ab684f; 0x5873e7d6; 0x2f2d3add; 0x381525f7; 0x41d24c04; 0x651173af; 0x5eba481c; 0x314ec749; 0x772b3c71; 0x6ed78a03; 0x79a7fb37; 0x2032d4db; 0x511ce7c4; 0x363cef9e; 0x468b7aac; 0x4751c0bf; 0x3fb2fcbf; 0x796da3c1; 0x217c1296; 0x45f87b04; 0x25200f29; 0x0895d813; 0x603f6086; 0x099f1ac6; 0x49b93693; 0x10bcd12c; 0x38ea11fc; 0x67ec30f5; 0x17b565dd; 0x42b7fad8; 0x491f6d36; 0x180d96da; 0x2d5a8222; 0x704f3401; 0x2f288917; 0x53eb82f1; 0x0a5fecfe; 0x63d03f7f; 0x0fe07be5; 0x4af8cbc2; 0x1f2394fb; 0x0b618adf; 0x6f5559f4; 0x18f1e44d; 0x681a4a47; 0x431a3316; 0x2baf39c7; 0x27c23482; 0x5db9f995; 0x42156bb3; 0x7866ac03; 0x01c3bfbc; 0x350a2a67; 0x1c5bfdbb; 0x292a5700; 0x3e33186c; 0x1d33af1f; 0x7308e9b4; 0x765c61bc; 0x409e8f89; 0x14748453; 0x30e52509; 0x3f51a9be; 0x7501b7ee; 0x04e762f9; 0x7e495118; 0x1463777a; 0x059500d6; 0x775552b0; 0x02673caf; 0x754212a5; 0x78c34c06; 0x2121677b; 0x49438d47; 0x5087b578; 0x5bb7a20b; 0x2144ec27; 0x5aa22c1c; 0x54b84604; 0x15619666; 0x5ff5ca94; 0x41b9f45a; 0x0034ddea; 0x5625be11; 0x7bcd62df; 0x0d16cbea; 0x58ef30f6; 0x09fe0412; 0x0361b627; 0x1a7cf130; 0x649fa3b0; 0x0f7e0c6a; 0x5e0e4e10; 0x381cdd37; 0x64014603; 0x540960ac; 0x1c38ff5c; 0x5bd27172; 0x7c0857b9; 0x34eeeb9e; 0x6d0b4699; 0x52d6e86d; 0x64128c00; 0x7bda7fe1; 0x7bb8e215; 0x4d957340; 0x02acee12; 0x1884de8c; 0x5e6385ca; 0x334a34f7; 0x5795a7e4; 0x214be206; 0x34600bed; 0x7c8c9411; 0x168aa5eb; 0x76e1f81e; 0x0a6e7e9c; 0x7f404bda; 0x7c204266; 0x5aa70690; 0x3521e8fd; 0x7b7132ba; 0x030f3c8f; 0x4586a9cf; 0x18a8c511; 0x24ed1ba8; 0x0c5c200f; 0x1a3006f9; 0x7bb6fa5a; 0x7acc15e5; 0x474e25a5; 0x39c79608; 0x16991d13; 0x0eb92dac; 0x4d4ebb78; 0x35ae0456; 0x1471045b; 0x5d973841; 0x67ac9171; 0x56fb51a7; 0x51a11e37; 0x117061a3; 0x067ccf09; 0x4b7ba5ec; 0x528b86c7; 0x40ded105; 0x5f72760f; 0x434e403c; 0x3af87594; 0x448e23e6; 0x3b691e33; 0x10494bc0; 0x4733491c; 0x646d878f; 0x362ff651; 0x1fc40f74; 0x19daf33a; 0x47d8d4f4; 0x6e6f00fb; 0x6b8a3dd5; 0x6eaee4b4; 0x5109c559; 0x28d105b7; 0x1afec99f; 0x2c9b84f7; 0x3f114f1c; 0x0b87f72b; 0x2e14e12a; 0x6354cbdf; 0x4ec38c70; 0x63f08c96; 0x6cb346ca; 0x2432d028; 0x5df0d457; 0x4b76cc7d; 0x3e38be0d; 0x70c5a954; 0x41550208; 0x680feb64; 0x2a82acc4; 0x7a9c85b7; 0x3324aff5; 0x5e141d55; 0x70be8c9e; 0x68a30356; 0x5df89b7c; 0x3df6dfc3; 0x30f35754; 0x1f1fa925; 0x2207fd1d; 0x47effb71; 0x108d3839; 0x7941b7a1; 0x302dc574; 0x05fef5a9; 0x4c342ec0; 0x04b0ce4c; 0x1309c9fd; 0x3f8e0c2f; 0x79855054; 0x0eb3a21a; 0x684cd809; 0x290398b8; 0x3aa026c2; 0x17273476; 0x6fdf8b6b; 0x30ef722f; 0x75eb6763; 0x0f8d430a; 0x39e14076; 0x652471fb; 0x0a45dcd1; 0x25e16b8e; 0x2fc8fdd6; 0x4826f750; 0x6dc16eff; 0x67f3a5dd; 0x02ac5740; 0x7da61a61; 0x5fe9533b; 0x7e8c58e3; 0x797f3b58; 0x0ea20699; 0x542e4c2a; 0x53e75ba3; 0x2ec97866; 0x3ac1ff3b; 0x22bfc07a; 0x45e73674; 0x0144065b; 0x3c0ec76e; 0x78050acc; 0x47ecdb57; 0x1afeac12; 0x1542a90e; 0x26489bec; 0x30a168c6; 0x222c2688; 0x72431f1f; 0x70c2d21c; 0x1e46a56b; 0x30869b17; 0x59de0a06; 0x40f9d6b7; 0x7b32d7e6; 0x444bc254; 0x64a5069b; 0x799c4b5b; 0x3ca9163c; 0x3ef776dd; 0x62602e70; 0x00002679; 0x75569eed; 0x5b5f3f82; 0x5882a453; 0x39c48214; 0x46525ef5; 0x657190e7; 0x5c948948; 0x749043c6; 0x06d4db2d; 0x2d1e29f9; 0x1f1b323b; 0x0da6d6a9; 0x37639739; 0x1fc814b9; 0x379ff0ec; 0x3c5f9476; 0x1a5df0f1; 0x408a3f01; 0x2553af76; 0x6c18addd; 0x2fd2d4d2; 0x14b1b50c; 0x1687dd88; 0x4a84da93; 0x2e83ab3c; 0x0b6ac942; 0x3ae9ecc6; 0x266c8b7d; 0x756dd3d8; 0x4447e9f8; 0x62e25f8d; 0x0560a63f; 0x265c4749; 0x4e87260b; 0x3a0a430f; 0x60671370; 0x4ff46bfa; 0x3372c0f0; 0x651f9d22; 0x7b1faf54; 0x76fcf0eb; 0x139847ac; 0x2a8e7a31; 0x4fddde40; 0x2856cea6; 0x265b76ff; 0x469fd6fb; 0x44d9c077; 0x3e2d4256; 0x4733d4b0; 0x73d632ae; 0x36e9999a; 0x5d9a4f8f; 0x21658e39; 0x2db4d86e; 0x767eec80; 0x6c36bfc7; 0x0dda4d1c; 0x6dda33ee; 0x1b9261cd; 0x2f3a7795; 0x74d56676; 0x5184ef61; 0x5b25905d; 0x465b1aed; 0x3e766f73; 0x36b30a0d; 0x45cc8798; 0x16d0ce43; 0x07286758; 0x3a59862c; 0x31d00cd7; 0x17d42673; 0x19bf81d3; 0x6385dc15; 0x7e703d90; 0x0db0c974; 0x63203505; 0x1594160f; 0x029d1854; 0x0f0f9299; 0x3052e271; 0x6a7ffaf6; 0x7e91fa69; 0x5f31bed4; 0x33682c5e; 0x44514cd0; 0x551e7aeb; 0x5bdb597a; 0x748b7da5; 0x7e7e077c; 0x47c06929; 0x353e16b1; 0x3f2c2468; 0x5284cf94; 0x4f480e32; 0x4dffb244; 0x58066686; 0x7097fcba; 0x09727855; 0x5a8a74c4; 0x2c83cf3f; 0x7693ffa4; 0x26691300; 0x12b882a7; 0x25530d92; 0x4623e215; 0x691fbcb9; 0x2d8e824c; 0x2b895d52; 0x33de6ca4; 0x616cae4e; 0x22ae8643; 0x4053ac72; 0x5b01b5e7; 0x1300cd17; 0x408fc301; 0x1f5e5442; 0x4a5dc893; 0x21434107; 0x245ae089; 0x60d679b5; 0x0d292a41; 0x25480806; 0x220fdab4; 0x048af2c0; 0x1f8032d5; 0x268ff019; 0x09e38d40; 0x40a5a290; 0x21708e87; 0x63da1685; 0x0ac301cc; 0x69d8796b; 0x6f1c97f8; 0x3c27dca5; 0x05e0a2b8; 0x3ade7473; 0x0422f0ef; 0x31a7d37d; 0x5e830407; 0x4099d01e; 0x68fb3ad8; 0x216adf5e; 0x6849c8a2; 0x3a1707ac; 0x30e592e4; 0x6f20f9a2; 0x7f853add; 0x58d4c511; 0x74efa634; 0x373e29b8; 0x69ef5143; 0x26fe16db; 0x6ca91698; 0x347e987b; 0x2671f037; 0x67257324; 0x2da0d813; 0x17f9fa3d; 0x32b624ef; 0x5252c26c; 0x7c30d021; 0x5cf6d6ae; 0x0bfc4352; 0x6ecffa4e; 0x7d400015; 0x347f286d; 0x4a0474d5; 0x2072a8f8; 0x2e79e95e; 0x2e60bdda; 0x6961cf7e; 0x280c9b95; 0x0305a4d3; 0x31dc74bd; 0x1b20088e; 0x1b2c8594; 0x7911a714; 0x273c3c43; 0x11848cd6; 0x6d71419e; 0x1d3983a6; 0x2ec1d7c6; 0x28cda532; 0x1d86d12f; 0x776f0e1a; 0x79c4452d; 0x0a594f60; 0x04791d6a; 0x333f7931; 0x19b9ff9d; 0x2a57184b; 0x16af5b6d; 0x3fc82d59; 0x01e272ce; 0x01257672; 0x3e9478ff; 0x26829a13; 0x3bcf5f33; 0x58b5d676; 0x074d58aa; 0x5adfa131; 0x239c1681; 0x632d597e; 0x78f7d7ec; 0x7d9a7d3f; 0x711e4c48; 0x40f30a20; 0x16822483; 0x0d118aa6; 0x083185a8; 0x50ada604; 0x2007523a; 0x72c56a6c; 0x130748ae; 0x53df84b1; 0x12b55f26; 0x11023f87; 0x371a92b8; 0x6d631b98; 0x11ef6e51; 0x42964e17; 0x0e22ee39; 0x50de6086; 0x7d57e4dd; 0x2a410f1f; 0x2b086094; 0x35a442d9; 0x1a964adf; 0x44508c96; 0x6d921dfe; 0x57ebbdd1; 0x07237a84; 0x5826b164; 0x658bd900; 0x5f834ca7; 0x2274d894; 0x6f86aa44; 0x3b11adb5; 0x2cfb27fb; 0x56ffaa50; 0x4b4ca939; 0x42a7622f; 0x59c04842; 0x7b0b42d1; 0x65c4f25b; 0x297d8a84; 0x45cbcada; 0x69ac322f; 0x598837fd; 0x41817c20; 0x3b6e3329; 0x3b85f393; 0x15c6ff93; 0x679cc80a; 0x18f01b71; 0x77567276; 0x785b2bdd; 0x7c406f95; 0x48fcf9bb; 0x71c2da2d; 0x3c58dc4f; 0x217c93bb; 0x41113a1f; 0x5ce74b9b; 0x57df20ed; 0x5d265d55; 0x5e8dc8ba; 0x1392c19e; 0x1ed4290b; 0x6c3126f5; 0x180e41ca; 0x7cd48e32; 0x08121bc5; 0x6e930d2e; 0x5743e0bf; 0x0822b61c; 0x54a6c82a; 0x2cc41a2b; 0x1a5ab09c; 0x410f6118; 0x32cac84c; 0x1b740c70; 0x241e3ad7; 0x1b31e477; 0x0c9841ea; 0x73c21a51; 0x1c1a618c; 0x5478b0d6; 0x31a6a65c; 0x6d0b7b39; 0x2f73b1b9; 0x2ddafe6b; 0x2245b5c4; 0x7ae15b42; 0x5731641b; 0x569a1be5; 0x56c6a297; 0x57512a57; 0x1d8b40ff; 0x11cbd5c3; 0x29736a8d; 0x37bf91b2; 0x7eb93c76; 0x047bda38; 0x24535c0b; 0x6b6a067a; 0x5f5e4d39; 0x6a5429d7; 0x0df1c0f7; 0x78efc153; 0x1f7f1964; 0x0d51cad3; 0x0d734b26; 0x431077a3; 0x49a72bf0; 0x21070b95; 0x147665a5; 0x643ce158; 0x51757bd7; 0x33ebd27b; 0x0c921d18; 0x3537839c; 0x0bb4d843; 0x181f31e9; 0x602ebd21; 0x41748069; 0x33d4c4e6; 0x47358ca8; 0x72d4cb6b; 0x4ec0df43; 0x646073d8; 0x694f4eb9; 0x50368fcf; 0x5b700654; 0x21e80f55; 0x11f426f3; 0x40432412; 0x762b3724; 0x2160aea0; 0x5c7fc768; 0x70e6bb52; 0x45dab133; 0x7f8f0890; 0x37205690; 0x4b193e9f; 0x1633466d; 0x098481c1; 0x53dd0b0b; 0x07dea63f; 0x6d74cb9b; 0x4ceb70d3; 0x2bbddc09; 0x1782bef2; 0x0ad6d41a; 0x035cd567; 0x11ba1685; 0x4d73a9c6; 0x7842ed43; 0x36e2e83e; 0x32ca3aa5; 0x0c89fd71; 0x61bdc8ad; 0x02f008fe; 0x5a6ff452; 0x3efab8a9; 0x3907f9e9; 0x4e97ed88; 0x62a794b6; 0x2f480163; 0x29d15968; 0x1dad0fea; 0x5d8cfb48; 0x42ff1c75; 0x13a0521b; 0x6754a0e8; 0x2aff406a; 0x50fea2b8; 0x2e36c504; 0x3c4d85de; 0x0964b7d5; 0x5ccf49b5; 0x1af19321; 0x63707df0; 0x70cf185c; 0x50138647; 0x06e8ff90; 0x38961917; 0x6a396953; 0x1cb90193; 0x0cbfe4d7; 0x64dd988f; 0x0736468f; 0x35f84f8e; 0x7983aa23; 0x545740b1; 0x74237836; 0x76893adb; 0x3e50fe38; 0x6a3d937b; 0x6df4c840; 0x75ddd9dd; 0x6dc91b59; 0x7e47c42d; 0x6f2d19fe; 0x7cf7fc32; 0x75185c96; 0x3e797881; 0x34f07631; 0x13bcd484; 0x4569ddf1; 0x74090c7d; 0x29365247; 0x25c371eb; 0x44137e5b; 0x6cc51415; 0x30762aef; 0x28f11954; 0x59d07259; 0x4a57d71d; 0x6a9896b9; 0x4dc11e4d; 0x7a7e9207; 0x0fe6ad68; 0x291203a1; 0x5d398557; 0x7e8b5a9d; 0x3ffa702a; 0x6ca0c886; 0x7530b7f1; 0x6e9f6e0f; 0x6c1749fe; 0x790f3ceb; 0x009f2d67; 0x1cf629f9; 0x19ae6ba7; 0x3407671b; 0x5b885f40; 0x0f55601e; 0x31080ba0; 0x71b7b0fa; 0x3e5f9391; 0x3467665c; 0x6dbc7f38; 0x702046e9; 0x767da59f; 0x18eb9679; 0x0c3621d7; 0x2380e54f; 0x7bfe5b04; 0x020dbba0; 0x550c7a2a; 0x43e7b76b; 0x7f44d8c6; 0x3c526d50; 0x453211d6; 0x361aaaa0; 0x129b23a8; 0x1bd63dbc; 0x6cc63dde; 0x7ab77598; 0x786a95ce; 0x1e23af14; 0x43acad9c; 0x419372ec; 0x25411a86; 0x5465bc2f; 0x20449f6d; 0x7fbd94be; 0x4411cf1f; 0x6dcf55fb; 0x64125ea6; 0x4298c20d; 0x67df4109; 0x2c3ace7c; 0x09d3aad5; 0x023681ec; 0x1de1f9db; 0x69f0633f; 0x54e6ce94; 0x4ca11174; 0x50f72f47; 0x7f1f98fe; 0x2d3e5659; 0x073736ae; 0x42877e3b; 0x2e4e2b89; 0x10b55972; 0x0af55b61; 0x5154e80b; 0x6f6fe9af; 0x70d9bc90; 0x0e6833d1; 0x16de5a20; 0x0a481167; 0x1486e00c; 0x7b0fe5ca; 0x484a133f; 0x65d733a9; 0x4f9e00ac; 0x38c14ecb; 0x6fe29b81; 0x69c5cfa9; 0x763d1873; 0x048ac156; 0x61967c50; 0x779f1454; 0x7b7a663d; 0x5afb565c; 0x596dce7d; 0x22c0c326; 0x3a592474; 0x6f8edcdb; 0x2bc4d942; 0x5e5ffc10; 0x5442141c; 0x5a0e2c27; 0x1b489c03; 0x2c23e85d; 0x58fa7b86; 0x5f73ad96; 0x02b51704; 0x1327eb6e; 0x59a0061d; 0x118aa361; 0x1b6c6557; 0x15aa565e; 0x2814eb75; 0x5e53caa9; 0x25e2b857; 0x68bf638a; 0x44f61364; 0x5ae8462b; 0x6d48d6d9; 0x6304ace4; 0x3b91c341; 0x2967b9fb; 0x45024c77; 0x604a2270; 0x1c30ff53; 0x2c988d4c; 0x0fea9a0f; 0x4b1fccf7; 0x12bc8dcf; 0x5a1347d9; 0x15bf46df; 0x24d2aa19; 0x473c3632; 0x19c231a0; 0x2be3fbfa; 0x18e8fa6c; 0x1f7712d1; 0x26e4406c; 0x4a600e60; 0x075e839c; 0x37ec6e60; 0x41462304; 0x3c0595b2; 0x327ad663; 0x6be13716; 0x190f81d6; 0x7d1c6b98; 0x72b9f8cd; 0x62c30f13; 0x0b34755b; 0x0fddfe79; 0x3e0cfe7b; 0x25d31d74; 0x1d44012f; 0x16da5de2; 0x5ef01725; 0x7e13ca69; 0x3036ce30; 0x39fdbb34; 0x079678cc; 0x21c30525; 0x65deb91f; 0x26e9be6c; 0x54e20fcc; 0x707829c0; 0x63323bb2; 0x5a1e6a08; 0x2ba16005; 0x16bc9631; 0x7475b468; 0x0407e507; 0x6d24c699; 0x4c33ee1d; 0x62efce79; 0x50a2f4f6; 0x42229e31; 0x3f4c4961; 0x63a6b947; 0x16d7a8c6; 0x0598c085; 0x1d91419c; 0x045b4a53; 0x284108f0; 0x577e69ab; 0x0d649e45; 0x24fae66d; 0x2eadf440; 0x4d5f6417; 0x09e581b7; 0x2f447274; 0x624a0027; 0x41cae7bd; 0x3d06ae77; 0x1ee378a3; 0x268baefb; 0x50035c8d; 0x17ae1c85; 0x15345501; 0x628acabb; 0x1567b406; 0x352917c7; 0x17d4a5a1; 0x05b648b7; 0x4094686f; 0x2edaedaa; 0x0a32db9e; 0x2aa15578; 0x11addd06; 0x1b4e5a94; 0x7a53d077; 0x11748058; 0x530be3f2; 0x10937921; 0x0469562b; 0x7dfa8fb6; 0x426d4252; 0x4c192f20; 0x04f8a476; 0x58fe9b14; 0x77de7a4a; 0x51609341; 0x1e6c74b6; 0x74b38a0d; 0x085381d1; 0x60aac8ef; 0x0971a023; 0x45c5a95c; 0x4da0686a; 0x5e2a4c5a; 0x14daa0a3; 0x4850a830; 0x23a319ce; 0x7c22c3de; 0x524ac220; 0x2f927599; 0x4627750e; 0x5ec5db47; 0x331165ce; 0x3486b1db; 0x65652199; 0x6eebe579; 0x2d56adf6; 0x3b9bd897; 0x7974d142; 0x36b3237f; 0x0cd82758; 0x648d3fe3; 0x5b694c94; 0x50322ec6; 0x700ee6ee; 0x562ec453; 0x671f9758; 0x34e80c7d; 0x116d0859; 0x6a97c18f; 0x054f25a4; 0x0bc2a697; 0x6273ac62; 0x6b0975d7; 0x444f5146; 0x0377f031; 0x418ba915; 0x7f857063; 0x2e93ab13; 0x7e7edbed; 0x7b8a437b; 0x132bbe00; 0x456914b3; 0x1c5f90b9; 0x2359bbe7; 0x5f6278ce; 0x7802792d; 0x2c005dd4; 0x66c23472; 0x73bb8b8e; 0x7cdba979; 0x1cc2485f; 0x5ad0931c; 0x7ad7445d; 0x566e9885; 0x5bb034c5; 0x3c630a22; 0x15548246; 0x17673855; 0x3808bc81; 0x5e73733a; 0x751f927e; 0x112f572a; 0x15932165; 0x6b31c526; 0x2e9ecbac; 0x2e10a087; 0x58f7e3bd; 0x01d382e6; 0x5814e1c9; 0x0a475c17; 0x2f32212f; 0x2f475f4c; 0x3c77f4f9; 0x46cbd248; 0x2c808e7c; 0x36c1e12c; 0x5ece2924; 0x64093cb5; 0x7d6cbe86; 0x5b00438f; 0x6983fbff; 0x00caef98; 0x2feb743f; 0x0d256f38; 0x739cf77d; 0x243aad7d; 0x083e20f7; 0x38f6b019; 0x38ea8331; 0x2dc5b3ec; 0x4d5b0b11; 0x24bf5fbb; 0x46c8dcfc; 0x3ba9c518; 0x1a0f5d9a; 0x1f7648c9; 0x2a6dcdf7; 0x0d829242; 0x60ca6248; 0x155a6a61; 0x43e42fde; 0x2087d99e; 0x38ba550d; 0x7f315e35; 0x6806f767; 0x1f4c30d1; 0x4e1e8560; 0x362da316; 0x0d0acfae; 0x7bce9bf7; 0x20401a21; 0x08303e1e; 0x1bd9a513; 0x64d11aa6; 0x64d0aa3b; 0x67026dc9; 0x61577eb8; 0x35d3d97d; 0x3d4cb88d; 0x54fccb61; 0x1eff9973; 0x2cba2df8; 0x7b843eec; 0x2634a948; 0x394242c6; 0x416edcd1; 0x59650407; 0x4ed1b733; 0x4c9493e8; 0x24959355; 0x4e2bac29; 0x6955df21; 0x3944d044; 0x7cfdfdb2; 0x703ae235; 0x51d67f32; 0x0992f427; 0x4f224846; 0x20cee51c; 0x0570782c; 0x1cc8ff95; 0x5fcb8068; 0x1b6c2a00; 0x736dd8e1; 0x43cc41e3; 0x3b63d6a3; 0x7770f5eb; 0x50afe778; 0x430e4dc6; 0x4668c374; 0x18c760ec; 0x18f22693; 0x58bcf051; 0x74f56e60; 0x63f24409; 0x1d6191f8; 0x040bfe56; 0x131e5dcd; 0x5850edb6; 0x59a92d3b; 0x206885e7; 0x43ca9bd6; 0x095458e6; 0x22a70ac0; 0x74685770; 0x372155d0; 0x40d09db7; 0x4cd36de1; 0x6d77d424; 0x37a5d94c; 0x017b484e; 0x409f8957; 0x7e4c12db; 0x0c57a857; 0x6667b40d; 0x2157f12e; 0x7703635a; 0x34a6829f; 0x1c407140; 0x08033dc8; 0x02f6dabf; 0x6e58c020; 0x0d5378a3; 0x7a911d20; 0x6c0eab72; 0x0aabc581; 0x7224e8d1; 0x2cf6b087; 0x6ffbd3b0; 0x7e50ef20; 0x032cbb53; 0x5653caa8; 0x6cfa9e5f; 0x29bd2155; 0x77c34326; 0x1d012344; 0x46a596b4; 0x513451d5; 0x5e7bb2b1; 0x1ac176a4; 0x6f49d87b; 0x715f8c4d; 0x5b05e61e; 0x7c59a91f; 0x26ed0079; 0x1f4504b9; 0x63e87fab; 0x41fd273f; 0x24c53987; 0x6df889b8; 0x5a683c24; 0x38e503fc; 0x3598f563; 0x5ba4542c; 0x471a740d; 0x676a34d1; 0x56a3b9f5; 0x026dec82; 0x4091a3d7; 0x1f72d34d; 0x589b8169; 0x7e414787; 0x4bdfb8c9; 0x1674fcb9; 0x62427cf2; 0x4beaab4d; 0x7c0a2a01; 0x33d9babe; 0x588a277e; 0x2d398e19; 0x4e54cd78; 0x02f857d9; 0x2afe1811; 0x6a03cb87; 0x58267f5b; 0x613ea973; 0x463dea69; 0x5deeba8b; 0x590a37a4; 0x24d2db78; 0x27310d90; 0x0f98c9ab; 0x48e31f0e; 0x527ee562; 0x253f21c6; 0x76872099; 0x36677eaf; 0x5ebb17f6; 0x4efc3013; 0x4256eaa3; 0x0b2c1a4c; 0x2a8ca51a; 0x1b727c33; 0x55b6288c; 0x3b061e3d; 0x7684f682; 0x30cfb12a; 0x23bef885; 0x67f9aba5; 0x3fde97c4; 0x555511f3; 0x4456819a; 0x43464142; 0x6de69bea; 0x5884ef58; 0x05e4487e; 0x4f7dce1e; 0x0c90dd18; 0x6e62ce60; 0x33a739d6; 0x6036d72f; 0x310cf761; 0x68e624d3; 0x29c6d2e5; 0x4be8b436; 0x625ae1f2; 0x33b93463; 0x61f91336; 0x1801620b; 0x5aaf48bc; 0x3b15d0f5; 0x226f174c; 0x140d7c05; 0x41a55879; 0x112ac22c; 0x0c7aa6cb; 0x266e66df; 0x47effa31; 0x5e442f15; 0x529db1fd; 0x7dbaf5c2; 0x261baabe; 0x6cc00620; 0x0f74584d; 0x56a51315; 0x025b0bcd; 0x436f02b3; 0x70a42f3d; 0x3d7ac7e6; 0x1f28b9ed; 0x08e68d39; 0x01cc0726; 0x43eeab05; 0x35b8068e; 0x0c9b19c9; 0x056a568e; 0x377ccfca; 0x2bab1e05; 0x04ab3472; 0x5699b826; 0x0d94ece0; 0x21d2de4f; 0x6077c505; 0x779b0139; 0x74f0d050; 0x3434d0cb; 0x7d654ea2; 0x76e60e02; 0x41048a1d; 0x0a8a8674; 0x469df399; 0x2b179d6d; 0x5ab96628; 0x7ee5d478; 0x3783a21e; 0x12fda64f; 0x28893262; 0x5dbeacb8; 0x20fc625e; 0x4666a285; 0x0691a6a7; 0x7025e507; 0x130a45ad; 0x3d456ba2; 0x0e511fa0; 0x35d70cd3; 0x46e2dcd8; 0x39db45e7; 0x35d727a1; 0x6e867631; 0x4a08d9d0; 0x0206774c; 0x100c02ce; 0x47a60b29; 0x48becb23; 0x21b599cd; 0x4a22c3a7; 0x4c0b6018; 0x0c83d6d6; 0x4e813962; 0x3d739fcb; 0x41999c64; 0x164ced4b; 0x16d8a84a; 0x4113fbfa; 0x6e4807c7; 0x28c3b3f6; 0x03071d36; 0x5159d26a; 0x087d88a4; 0x25fc1c06; 0x64f922e8; 0x65c519e5; 0x5d8f42fe; 0x16e658ec; 0x3f78b13b; 0x66da2f46; 0x4ee1d53e; 0x4dce69f7; 0x2479bf4f; 0x7af82284; 0x6a2175dd; 0x74a8a7b3; 0x438135f6; 0x0fd53da5; 0x2cf8856b; 0x0d0469a9; 0x31fc6f6c; 0x715a1d09; 0x6055a1eb; 0x10835a34; 0x3740e967; 0x57b353ad; 0x4cd619dd; 0x6b6a3566; 0x6f5a9dfe; 0x77c80a61; 0x2bfdee8b; 0x1816273d; 0x7cd74728; 0x553f44ce; 0x2a0e5ec1; 0x388c2068; 0x319a9a08; 0x0c2af395; 0x2949f75e; 0x41f9e9b6; 0x6063f3cc; 0x7d4ea5af; 0x7861296b; 0x17e0f3cf; 0x66012178; 0x043187bc; 0x5faa653d; 0x33cfc425; 0x53d378ca; 0x2155c31e; 0x712ab327; 0x6192c739; 0x25f491ea; 0x54a3d8b3; 0x55b3d1bf; 0x762c4a3a; 0x75aebb59; 0x416fcfa8; 0x628a446b; 0x0d8457ce; 0x79e603c1; 0x7cc575f0; 0x0a5ce0c5; 0x30b1ccfa; 0x00281d7e; 0x3cd2ed24; 0x7510c64c; 0x0be07209; 0x73526859; 0x65946359; 0x2a546f4f; 0x783a8965; 0x34182cc1; 0x2616b0bc; 0x724ab52d; 0x278dd50a; 0x71694e6f; 0x64f32ea7; 0x28ad21d9; 0x1c53c6ca; 0x6b0ba0a5; 0x2fe03f77; 0x188ac85a; 0x70b05fc0; 0x0046bd3d; 0x7637b718; 0x661f49d3; 0x5b854049; 0x5d3ca349; 0x0a30b188; 0x2fd1462c; 0x1d26f321; 0x5b8b7f1c; 0x45a48eb8; 0x5d86c8a6; 0x538daa6a; 0x2dc370a0; 0x17966abe; 0x45e629ed; 0x413c0ef8; 0x4ca449b9; 0x7d193d45; 0x57244bc4; 0x31094ad3; 0x2582e257; 0x70a5e3fa; 0x18e190e7; 0x57dd2f9b; 0x1c711f1d; 0x7bc6be06; 0x50d1b015; 0x051a7947; 0x06a92cf7; 0x5c2c30ba; 0x2c7a0ff4; 0x5805e415; 0x4510ba6d; 0x5cae9dc3; 0x7a0c0b6c; 0x1741079e; 0x5d49d0ff; 0x6bbc8294; 0x77c2692d; 0x326bf8e2; 0x54d4640e; 0x20012e23; 0x21013814; 0x30fddb5a; 0x75227b06; 0x1c20c1bb; 0x5f9bb584; 0x554ea171; 0x6068384a; 0x2be5bcd2; 0x6971a336; 0x11144076; 0x0170e151; 0x20e24325; 0x74c6e58f; 0x5f393389; 0x745070df; 0x76429400; 0x084a8659; 0x0c211b8b; 0x21faad9b; 0x540869f9; 0x6cbe4cf0; 0x1ba410b0; 0x1f9c752d; 0x2a2c9ac3; 0x579bca4e; 0x1c1877d7; 0x755c2547; 0x7e1ae9f6; 0x288d06e2; 0x41f55262; 0x6c85fae6; 0x2b95dd42; 0x5521b7ff; 0x4bc436c9; 0x4d41a34d; 0x73513ce9; 0x674ff0ca; 0x2a22cde2; 0x5a837b4a; 0x55746f29; 0x0ac4f596; 0x29a81b75; 0x2fb343a1; 0x01ec05be; 0x30c0baab; 0x1078a8b9; 0x54228b2e; 0x7f97ddef; 0x1fa2a455; 0x569e0dd2; 0x0c56fffd; 0x284ca4b9; 0x10103c78; 0x086c6758; 0x30008cb4; 0x47a53b98; 0x6dec2457; 0x48987cf7; 0x4cd2d2c6; 0x1ab87a7b; 0x782fa417; 0x5fb16aba; 0x05219cbe; 0x7d074008; 0x0b2728d9; 0x5285602d; 0x368d3435; 0x2278344c; 0x520ead89; 0x787e2018; 0x45045ce3; 0x0f489fcd; 0x0abf96e8; 0x27935beb; 0x51cef0f2; 0x0bd1573c; 0x73197e33; 0x3f31c0da; 0x31fc8b84; 0x3c4d7941; 0x64dc01ab; 0x187150a0; 0x76ab63a1; 0x78a7c190; 0x377ed885; 0x437d8255; 0x6c39d9d7; 0x7b7edc68; 0x320890ce; 0x03c2a57a; 0x4b4e3a12; 0x7ef496ac; 0x7d1ab3c4; 0x3fa61f8d; 0x1e9b72a3; 0x6c4a5021; 0x3860d04a; 0x51f7e47f; 0x4a0a633a; 0x15aff773; 0x7dba4f85; 0x7db57210; 0x0e37413e; 0x59e776e6; 0x093907f5; 0x175e975c; 0x4105c34c; 0x1fb7280a; 0x3e376f3c; 0x31c02402; 0x5304f8fd; 0x4c43eb12; 0x4b862a30; 0x2fb184c3; 0x06fc43a4; 0x059b463b; 0x5dd9b2c3; 0x0957fe28; 0x4243df3a; 0x382f2a3a; 0x55048d94; 0x0248b7b6; 0x60e21a20; 0x6457da2d; 0x484d9d89; 0x6606cbd0; 0x424e0d53; 0x3a5f3135; 0x6f12ea65; 0x77dbae6f; 0x52f147a4; 0x69ca4b9e; 0x35a4588a; 0x1dbc3d44; 0x15ef5b44; 0x57f2e339; 0x4d4931b7; 0x35cc2530; 0x38df8918; 0x25cd233b; 0x041f0ffc; 0x4cf5974b; 0x101783b8; 0x5de77ed1; 0x0599aff6; 0x69c913c8; 0x66e33f4e; 0x5eaa40bc; 0x2bae8234; 0x752eb641; 0x5b0e4add; 0x2cf6a007; 0x1edab0aa; 0x19d48222; 0x32468cb1; 0x08e6bfe0; 0x3e312826; 0x148f3db6; 0x3b729876; 0x149984e1; 0x71e39578; 0x197c67ed; 0x788b90a5; 0x2d508d8d; 0x4894022d; 0x06b89326; 0x25e8c6aa; 0x16011f3a; 0x1a51adaf; 0x29b38486; 0x3c8dc319; 0x5f370371; 0x62107783; 0x1fac01b5; 0x63b00ca0; 0x27a456dd; 0x514a48ae; 0x5882d384; 0x20715120; 0x78960a00; 0x51b4ee70; 0x72f6ce12; 0x5f11e080; 0x2541e6f1; 0x386663d2; 0x01abfd90; 0x6bf859c3; 0x4268690e; 0x3c21c8cc; 0x3d9204f1; 0x12da0f59; 0x2d50a1cd; 0x5b58291a; 0x1f9bc0c7; 0x0828411d; 0x2622389d; 0x2868b426; 0x112d1d34; 0x1c755f8f; 0x3ebc4805; 0x425a40e7; 0x1520c6dd; 0x38253512; 0x4986bf19; 0x61fd9d93; 0x4a91d7dd; 0x7e16c383; 0x61f6628a; 0x306e5fcc; 0x5c16d47c; 0x35384a14; 0x674e5bc2; 0x7bb151ba; 0x74517816; 0x65b99a87; 0x59c9f9a2; 0x5e6cc4cc; 0x1125a977; 0x141614fd; 0x185c71d4; 0x3cfbc510; 0x131ab579; 0x42d065bb; 0x58adedf1; 0x50615afd; 0x07a897a6; 0x3d2fb856; 0x25a1d19e; 0x6513d354; 0x10272655; 0x148be972; 0x2462df8b; 0x2313aaaa; 0x65df0efa; 0x0a231d35; 0x040bebb9; 0x5643531d; 0x40eaecc9; 0x383a4be5; 0x4eef678c; 0x7386d9bd; 0x249bee6c; 0x07fbccea; 0x3c649e71; 0x30dba936; 0x1a4e90b2; 0x3044b430; 0x66e80661; 0x25c329ac; 0x2d1ad481; 0x55aa6fbe; 0x37393436; 0x1d50e1b4; 0x5cc71611; 0x5d45e90b; 0x506fb608; 0x5b0750f2; 0x16e7da1f; 0x0e8d9bc1; 0x40c75f39; 0x00c42217; 0x65b81d97; 0x26fe162a; 0x10c42d49; 0x68961a29; 0x0b216608; 0x19516141; 0x7391975a; 0x07b0171b; 0x2270be0d; 0x4b56607d; 0x17abf6f4; 0x1d97d1f0; 0x094c7fdd; 0x2ad353a9; 0x11fa9c5e; 0x2f139267; 0x54bbe872; 0x2812c620; 0x57f580dd; 0x1acda829; 0x21e4f841; 0x054a7560; 0x4b6a5f58; 0x435f35d1; 0x7e70d241; 0x6bbca614; 0x2d7350bf; 0x2f8247ae; 0x5157f368; 0x0980275c; 0x381edf48; 0x00b7628b; 0x7f2244a7; 0x699cb3f2; 0x64bcc872; 0x407ab854; 0x1f2d337e; 0x79774b1c; 0x5b87738e; 0x1123e837; 0x2c549098; 0x1a7c30eb; 0x71033aa1; 0x7d90682e; 0x3e18a139; 0x17021dae; 0x7a4e00ee; 0x5dc05e30; 0x5b48d748; 0x1cba2635; 0x01b2bd26; 0x19f8b8b8; 0x074d8011; 0x44001ee4; 0x45635de4; 0x6adfab30; 0x2922110e; 0x0ce0e413; 0x7c5998b3; 0x49bc2d7e; 0x5e0c8700; 0x6c098f4b; 0x1a1f9f53; 0x0faa6ca2; 0x72bf68d6; 0x7a0b7a4e; 0x12810ff8; 0x18d2e8f5; 0x67c0882f; 0x35283420; 0x77562a4c; 0x4a70b6d7; 0x4171b839; 0x31ff85b8; 0x0244cf49; 0x0ca100ec; 0x18bb92b5; 0x16f8269e; 0x705a4c37; 0x034f02b1; 0x35eea06c; 0x2fa25dda; 0x49e05f6d; 0x2bcf7b1c; 0x7cd1c0b7; 0x75df237e; 0x5499aaeb; 0x361679c8; 0x0b820950; 0x25532980; 0x5be64b4a; 0x0df2ed58; 0x0776de7e; 0x120ab856; 0x262fd585; 0x079fcb96; 0x20515a07; 0x222e6b0a; 0x4a326a89; 0x17726911; 0x7740772c; 0x4d43e0ae; 0x1062c95f; 0x4c288603; 0x04e751be; 0x220cb789; 0x019e67d8; 0x0a4ae8e8; 0x4eabdfe8; 0x779a7125; 0x0abcba52; 0x4f1636ff; 0x180189ac; 0x7aa37c64; 0x5b6d34e0; 0x17662f15; 0x0014bd21; 0x0c2bf0d5; 0x1cdb9601; 0x60111e36; 0x49d5ef9b; 0x2ce1457a; 0x4dbd1236; 0x40dd7c03; 0x10d6ff53; 0x01f9e14b; 0x6359ecc2; 0x551b5368; 0x4ad84239; 0x6b15d7e7; 0x2384a1e9; 0x03af4e12; 0x51a36df0; 0x5c012bf2; 0x789c09cc; 0x5706b0a3; 0x2b24f048; 0x389b6ea4; 0x309619de; 0x550efe13; 0x17533d00; 0x1d7c3705; 0x0e44fcc3; 0x5d654e4f; 0x3b4f55e0; 0x4e86ee08; 0x64ed41e9; 0x588f125d; 0x4fee7f8c; 0x6748d08c; 0x733e7edc; 0x01c5131c; 0x494cf6c7; 0x45d3c79d; 0x70c43d4e; 0x775355ed; 0x2ac71136; 0x171986d8; 0x5f83c03b; 0x76f07660; 0x511ef21d; 0x53083afb; 0x6a2485eb; 0x63a1826a; 0x45a58842; 0x2c0e6a52; 0x639a1f57; 0x3937ed98; 0x1915b44f; 0x1a18140b; 0x73937457; 0x3407de32; 0x26b5f0e0; 0x1955df62; 0x7fec7c58; 0x0465e209; 0x36bd0139; 0x7eea79aa; 0x308a8d4f; 0x7d1a4ff8; 0x49dc3f71; 0x1a637f96; 0x1106bd39; 0x093427bf; 0x13c5df63; 0x40d8c0ea; 0x6901d06c; 0x7b3c8faf; 0x19c57b04; 0x31f722d1; 0x28906d5e; 0x5fcacd4f; 0x7220d1c2; 0x7ca1e5f3; 0x3e357efd; 0x26b5ab7d; 0x776fa67f; 0x593e89d4; 0x60c55d19; 0x25a537f6; 0x4d212343; 0x37d958a2; 0x355b5b7e; 0x7c8168c5; 0x4a40a28b; 0x64892e03; 0x5dbfa9f9; 0x4462be59; 0x1c280fd4; 0x35ca1b1d; 0x428c16ed; 0x412b0065; 0x1b1d023c; 0x04f57182; 0x24c3532c; 0x057bc43d; 0x01b789f3; 0x1091e70b; 0x62d54cd8; 0x3ff7b86a; 0x7b7536fe; 0x584b7537; 0x1706075b; 0x6b472e5b; 0x21479a34; 0x487d73b3; 0x125d559a; 0x31fd960e; 0x210bc42a; 0x53736956; 0x506a54b6; 0x6166fbab; 0x5f4ef625; 0x144cc0b6; 0x0dd8080a; 0x61f2463c; 0x5e55d215; 0x649a4ae9; 0x389715e9; 0x5b4de964; 0x75512f7b; 0x57640cf1; 0x3aaf0948; 0x715e4549; 0x6b894fb4; 0x22073a23; 0x1e6e840a; 0x5168de1f; 0x084873a6; 0x42b90605; 0x5e9a0e41; 0x71d0f075; 0x6fa752d4; 0x56497365; 0x5bc57ff8; 0x2e061440; 0x454831da; 0x6b261bad; 0x4ea3796c; 0x1e67a05e; 0x2002265d; 0x12d8a4b9; 0x401251f5; 0x447f2086; 0x2adc1357; 0x71b39152; 0x48575c94; 0x4dd14f36; 0x0f96f549; 0x77db980e; 0x352f423f; 0x7f0ed38a; 0x0fddf56b; 0x7be6cf92; 0x41eab5b6; 0x57dfdd78; 0x6a5f34cf; 0x39c054b2; 0x7e2a627c; 0x7bb4839b; 0x2b1f4fd3; 0x1e3d0271; 0x2d650bfe; 0x4d8f43e5; 0x6ff5dc13; 0x3e3fa0b2; 0x2140b2d3; 0x516da92e; 0x43fb1d3c; 0x5b94011c; 0x153902f3; 0x2162c3d6; 0x712f52b5; 0x6eaecfb7; 0x59429c40; 0x5ddd6681; 0x626685c5; 0x5dd22826; 0x4b2dc96a; 0x0438a69a; 0x239304fe; 0x7c868c07; 0x4eee5fa4; 0x120e5b8c; 0x4767aae0; 0x648c36b1; 0x24bae5cc; 0x7b9ddf36; 0x4f94cb47; 0x1b7faeea; 0x73fa82ca; 0x4c32d990; 0x092d0c93; 0x4315711b; 0x3fcc0592; 0x5d0a5111; 0x48d6ba90; 0x1e444b21; 0x40c16fcf; 0x6867f5b1; 0x57a476ea; 0x175f2304; 0x1ffc5cfe; 0x6a7ba53a; 0x637b599c; 0x1404dd83; 0x0805aa32; 0x10d47daf; 0x2db94dc2; 0x1a1f3371; 0x61cc8fb3; 0x3711c483; 0x28a61268; 0x2ed93c6e; 0x2e42ed8c; 0x1a387531; 0x6b1bd449; 0x301efe32; 0x5dcf70d0; 0x3dd03c00; 0x1153313d; 0x129c2b48; 0x3b9d34b9; 0x2ba65435; 0x6e0426bb; 0x1955c17b; 0x4f0e1b76; 0x028d41c9; 0x02d475d3; 0x2ef7c30f; 0x2ea73087; 0x357c92a5; 0x4141569c; |] (* %%MAGICEND%% *) let () = assert(Array.length hash_data >= hash_length + digest_length - 1) (** Integer hashes. *) (* %%MAGICBEGIN%% *) module HashCode = struct type t = { mutable digest : int; mutable code : int } let create () = { digest = 0; code = 0 } (* * Add an integer. *) let add_truncated_bits ({digest ; code} as buf : t) (i : int) : unit = let code = (code + i + 1) mod hash_length in buf.digest <- (digest * 3) lxor (Array.unsafe_get hash_data code); buf.code <- code let add_bits buf i = add_truncated_bits buf (i land 0x7ff) (* last 11 bits*) (* * Add the characters in a string. *) let add_string buf s = for i = 0 to String.length s - 1 do add_truncated_bits buf (Char.code (String.unsafe_get s i)) done (* * Numbers. *) let add_int buf i = add_bits buf i; add_bits buf (i lsr 11); add_bits buf (i lsr 22) let add_int32 buf i = add_bits buf (Int32.to_int (Int32.shift_right_logical i 16)); add_bits buf (Int32.to_int i) let add_int64 buf i = add_int buf (Int64.to_int (Int64.shift_right_logical i 48)); add_int buf (Int64.to_int (Int64.shift_right_logical i 24)); add_int buf (Int64.to_int i) let add_nativeint buf i = add_int buf (Nativeint.to_int (Nativeint.shift_right_logical i 48)); add_int buf (Nativeint.to_int (Nativeint.shift_right_logical i 24)); add_int buf (Nativeint.to_int i) let add_float buf x = add_int64 buf (Int64.bits_of_float x) (* * Extract the digest. *) let code buf = buf.digest end (* %%MAGICEND%% *) (************************************************ * Digest-based hashes. *) (* %%MAGICBEGIN%% *) module HashDigest = struct type t = { digest : int array; mutable code : int } (* * New buffer. *) let create () = { digest = Array.make digest_length 0; code = 0 } (* * Add an integer. *) let add_truncated_bits ( { digest ; code } as buf :t) i = let code = (code + digest_length + i) mod hash_length in for i = 0 to digest_length - 1 do digest.(i) <- (digest.(i) * 3) lxor (Array.unsafe_get hash_data (code + i)) done; buf.code <- code let add_bits buf i = add_truncated_bits buf (i land 0x7ff) (* * Add the characters in a string. *) let add_char buf c = add_truncated_bits buf (Char.code c) let add_string buf s = for i = 0 to String.length s - 1 do add_char buf (String.unsafe_get s i) done let add_substring buf s off len = if off < 0 || len < 0 || off + len > String.length s then raise (Invalid_argument "Lm_hash.add_substring"); for i = off to pred (off + len) do add_char buf (String.unsafe_get s i) done (* * Numbers. *) let add_bool buf b = add_truncated_bits buf (if b then 1 else 0) let add_int buf i = add_bits buf i; add_bits buf (i lsr 11); add_bits buf (i lsr 22) let add_int32 buf i = add_bits buf (Int32.to_int (Int32.shift_right_logical i 16)); add_bits buf (Int32.to_int i) let add_int64 buf i = add_int buf (Int64.to_int (Int64.shift_right_logical i 48)); add_int buf (Int64.to_int (Int64.shift_right_logical i 24)); add_int buf (Int64.to_int i) let add_nativeint buf i = add_int buf (Nativeint.to_int (Nativeint.shift_right_logical i 48)); add_int buf (Nativeint.to_int (Nativeint.shift_right_logical i 24)); add_int buf (Nativeint.to_int i) let add_float buf x = let i = Int64.bits_of_float x in add_int buf (Int64.to_int (Int64.shift_right i 48)); add_int buf (Int64.to_int (Int64.shift_right i 24)); add_int buf (Int64.to_int i) (* * Extract the digest. *) let digest buf = let digest = buf.digest in let s = Bytes.create digest_length in for i = 0 to digest_length - 1 do Bytes.set s i (Char.chr (digest.(i) land 0xff)) done; Bytes.unsafe_to_string s end;; (* %%MAGICEND%% *) (************************************************************************ * Hash helper functions. *) (* * The default function for combinding hash values. * XXX: JYH: we should try using a smarter hash function. *) let hash_combine (i1 : int) (i2 : int) = (i1 lsl 2) lxor (i1 lsr 2) lxor i2 (** Hash a list of integers. *) let hash_int_list code l = let buf = HashCode.create () in HashCode.add_int buf code; List.iter (HashCode.add_int buf) l; HashCode.code buf let hash_list f lst = let buf = HashCode.create () in List.iter (fun dir -> HashCode.add_int buf (f dir)) lst; HashCode.code buf omake-0.10.3/src/libmojave/lm_list_util.ml0000644000175000017500000004361513177364665017137 0ustar gerdgerd (* * Exception for operations that have no effect. *) exception Unchanged (* * Array-style operations. *) let sub = let rec skip l off len = if off = 0 then collect [] l len else match l with _ :: l -> skip l (off - 1) len | [] -> raise (Invalid_argument "Lm_list_util.sub") and collect l1 l2 len = if len = 0 then List.rev l1 else match l2 with x :: l2 -> collect (x :: l1) l2 (len - 1) | [] -> raise (Invalid_argument "Lm_list_util.sub") in skip (* * Iterate over two lists, but stop at the end of the * shorter one. *) let rec short_iter2 f l1 l2 = match l1, l2 with h1 :: l1, h2 :: l2 -> f h1 h2; short_iter2 f l1 l2 | _ -> () let rec iter3 f l1 l2 l3 = match l1, l2, l3 with h1 :: l1, h2 :: l2, h3 :: l3 -> f h1 h2 h3; iter3 f l1 l2 l3 | [], [], [] -> () | _ -> raise (Invalid_argument "iter3") (* * Filter items out of a list. *) let rec filter f = function | [] -> [] | (h::t) as l -> if f h then let rem = filter f t in if rem == t then l else h::rem else filter f t (* * Insert an element into a position. *) let rec insert_nth i x l = if i = 0 then x :: l else match l with h::t -> h :: insert_nth (i - 1) x t | [] -> raise (Failure "Lm_list_util.insert_nth") (* * Remove an element from a position. *) let rec remove_nth i l = match l with | x :: l -> if i = 0 then l else x :: remove_nth (pred i) l | [] -> raise (Failure "Lm_list_util.remove_nth") (* * Work left-to-right, but reverse the result. *) (* let rec rev_map' f l = function *) (* h :: t -> *) (* rev_map' f (f h :: l) t *) (* | [] -> *) (* l *) (* * Reverse do_list. *) let rec rev_iter f = function h::t -> rev_iter f t; ignore (f h) | [] -> () (* * Flat map. *) let rec flat_map_aux f accum l = function | h::t -> flat_map_aux f (h::accum) l t | [] -> begin match l with | [] -> accum | h :: t -> flat_map_aux f accum t (f h) end let flat_map f l = List.rev (flat_map_aux f [] l []) (* * Map, and discard errors. *) let rec fail_map f = function h::t -> begin try let h = f h in h :: fail_map f t with Failure _ -> fail_map f t end | [] -> [] (* * Map, and discard None. *) let rec some_map_aux unchanged f = function h :: t -> begin match f h with Some h' -> h' :: some_map_aux (unchanged && h' == h) f t | None -> some_map_aux false f t end | [] -> if unchanged then raise Unchanged; [] let some_map_safe f l = try some_map_aux true f l with Unchanged -> l let rec some_map f = function h :: t -> begin match f h with Some h' -> h' :: some_map f t | None -> some_map f t end | [] -> [] (* * Cross between map and fold_left. *) let rec fold_left_aux f x l = function h :: t -> let x', h' = f x h in fold_left_aux f x' (h' :: l) t | [] -> x, List.rev l let fold_left f x l = fold_left_aux f x [] l (* * Generalize fold_left over three lists. *) let rec fold_left3 f arg l1 l2 l3 = match l1, l2, l3 with h1 :: t1, h2 :: t2, h3 :: t3 -> fold_left3 f (f arg h1 h2 h3) t1 t2 t3 | [], [], [] -> arg | _ -> raise (Invalid_argument "fold_left3") (* * Find the elemnt. *) let rec find f = function h::t -> if f h then h else find f t | [] -> raise Not_found let rec find_item_aux f i = function h::t -> if f h then i else find_item_aux f (i + 1) t | [] -> raise Not_found let find_item f l = find_item_aux f 0 l let rec find_index_aux v i = function h::t -> if h = v then i else find_index_aux v (i + 1) t | [] -> raise Not_found let find_index v l = find_index_aux v 0 l let rec fild_rindex_aux v i curr = function [] -> i | h :: t -> fild_rindex_aux v (if h=v then curr else i) (curr + 1) t let find_rindex v l = let i = fild_rindex_aux v (-1) 0 l in if i>=0 then i else raise Not_found let rec find_indexq_aux v i = function h::t -> if h == v then i else find_indexq_aux v (i + 1) t | [] -> raise Not_found let find_indexq v l = find_indexq_aux v 0 l (* * Find the index of an element in a list. *) let find_index_eq eq x l = let rec search i = function h :: t -> if eq x h then i else search (succ i) t | [] -> raise Not_found in search 0 l (* * Split a list. *) let rec split_list i l = match (i,l) with 0, _ -> [], l | _, h::t -> let l, l' = split_list (i - 1) t in h::l, l' | _, [] -> raise (Failure "Lm_list_util.split_list") (* * Split off the last item. *) let rec split_last = function [h] -> [], h | h::t -> let l, x = split_last t in h::l, x | [] -> raise (Failure "Lm_list_util.split_last") (* * Split based on an index. *) let rec split i l = if i = 0 then [], l else match l with h :: t -> let l1, l2 = split (pred i) t in h :: l1, l2 | [] -> raise (Invalid_argument "split") (* * Split into fragments. *) let splitup n l = let rec split i vll vl1 vl2 = match vl2 with v :: vl2 -> if i = 0 then split n (List.rev vl1 :: vll) [v] vl2 else split (pred i) vll (v :: vl1) vl2 | [] -> List.rev vl1 :: vll in match l with [] -> [] | h :: t -> split n [] [h] t (* * Get the last element. *) let rec last = function [x] -> x | _ :: t -> last t | [] -> raise (Invalid_argument "last") (* * Return the first n elements of the list. *) let rec firstn i l = if i = 0 then [] else match l with h :: t -> h :: firstn (pred i) t | [] -> [] (* * Nth tail. *) let rec nth_tl i l = if i = 0 then l else match l with _ :: l -> nth_tl (pred i) l | [] -> raise (Invalid_argument "nth_tl") (* * Functional replacement. *) let rec replacef_nth i f = function h::t -> if i = 0 then f h :: t else h :: replacef_nth (i - 1) f t | [] -> raise (Failure "Lm_list_util.replacef_nth") let rec replacef_arg_nth i f = function h::t -> if i = 0 then let h, arg = f h in h :: t, arg else let t, arg = replacef_arg_nth (i - 1) f t in h :: t, arg | [] -> raise (Failure "Lm_list_util.replacef_arg_nth") (* * Replace the nth element of the list. *) let rec replace_nth i x l = match l with [] -> raise (Invalid_argument "replace_nth") | h :: l -> if i = 0 then x :: l else h :: replace_nth (pred i) x l let rec replace_first f x = function h::t -> if f h then x :: t else h :: replace_first f x t | [] -> raise Not_found let rec replace_all f x = function h::t -> (if f h then x else h) :: (replace_all f x t) | [] -> [] (* * Functional replacement. *) let rec replaceq x1 x2 = function h::t -> if h == x1 then x2 :: replaceq x1 x2 t else h :: replaceq x1 x2 t | [] -> [] (* * Subtraction. *) let rec subtract_list l1 l2 = match l1 with h :: l1 -> if List.mem h l2 then subtract_list l1 l2 else h :: subtract_list l1 l2 | [] -> [] (* * map2to1 *) let rec map2to1 f l1 l2 = match l1, l2 with [], [] -> [] | h1::l1, h2::l2 -> f h1 h2 :: map2to1 f l1 l2 | _ -> raise (Invalid_argument "map2to1") (* * fold_left + map = fold_map *) let rec fold_map f i l = match l with [] -> i, [] | hd :: tl -> let i, hd = f i hd in let i, l = fold_map f i tl in i, hd :: l let rec fold_map2to1 f i l1 l2 = match l1, l2 with [], [] -> i, [] | h1 :: l1, h2 :: l2 -> let i, h = f i h1 h2 in let i, l = fold_map2to1 f i l1 l2 in i, h :: l | _ -> raise (Invalid_argument "fold_map2to1") let rec fold_map1to2 f i l = match l with [] -> i, [], [] | hd :: tl -> let i, hd1, hd2 = f i hd in let i, l1, l2 = fold_map1to2 f i tl in i, hd1 :: l1, hd2 :: l2 (* * fold + filter = fold_filter *) let rec fold_filter f x l = match l with [] -> x, [] | h :: t -> let x, b = f x h in if b then let x, t = fold_filter f x t in x, h :: t else fold_filter f x t (* * check list lengths equal *) let rec length_eq l1 l2 = match l1, l2 with [], [] -> true | _ :: l1, _ :: l2 -> length_eq l1 l2 | _ -> false (* * Add an element based on physical equality. *) let addq x l = if List.memq x l then l else x :: l (* * Intersect two lists. * Quadratic algorithm. *) let rec intersect l = function h::t -> if List.mem h l then h :: intersect l t else intersect l t | [] -> [] let rec intersectq l = function h::t -> if List.memq h l then h :: intersectq l t else intersectq l t | [] -> [] let rec intersects l = function h :: t -> List.mem h l || intersects l t | [] -> false (* * Subtract an element from a list. * Quadratic algorithm. *) let rec subtract l1 l2 = match l1 with h::t -> if List.mem h l2 then subtract t l2 else h :: subtract t l2 | [] -> [] (* * Subtract only the first occurrence. *) let rec mem_once v head = function h :: t -> if v = h then Some (head @ t) else mem_once v (h :: head) t | [] -> None let rec subtract_multiset l1 l2 = match l1 with h :: t -> begin match mem_once h [] l2 with Some l2 -> subtract_multiset t l2 | None -> h :: subtract_multiset t l2 end | [] -> [] (* * Subtract an element from a list. * Quadratic algorithm. *) let rec subtractq l1 l2 = match l1 with h::t -> if List.memq h l2 then subtractq t l2 else h :: subtractq t l2 | [] -> [] (* * Union of lists by structural equality. *) let rec union l = function h::t -> if List.mem h l then union l t else h::(union l t) | [] -> l (* * Union of lists by physical equality. * The semantics are important: * all the elements in the first argument that do not * exist in the second argument are consed _in order_ onto * the first argument. *) let rec unionq h l = match h with h :: t -> if List.memq h l then unionq t l else h :: unionq t l | [] -> l (* * The first list is a subset of the second one (based on structural equality) *) let rec subset l1 l2 = match l1 with x :: l1 -> List.mem x l2 && subset l1 l2 | [] -> true (* * Remove marked elements. *) let rec remove_elements l1 l2 = match l1, l2 with flag::ft, h::t -> if flag then remove_elements ft t else h :: remove_elements ft t | _, l -> l let rec removeq x = function h::t -> if h == x then t else h :: removeq x t | [] -> raise (Failure "Lm_list_util.removeq") let rec remove x = function h::t -> if h = x then t else h :: remove x t | [] -> raise (Failure "Lm_list_util.remove") let rec tryremove x = function (h :: t) as l -> if h = x then t else let res = tryremove x t in if res == t then l else h :: res | [] -> [] (* * Remove the specified suffix from the list. *) let rec remove_suffix_aux suffix = function (0, l') -> if l' = suffix then [] else raise (Failure "Lm_list_util.remove_suffix") | (i, _::t) -> remove_suffix_aux suffix (i - 1, t) | _ -> (* This will never happen *) raise (Failure "Lm_list_util.remove_suffix") let remove_suffix l suffix = let i = (List.length l) - (List.length suffix) in if i >= 0 then remove_suffix_aux suffix (i, l) else raise (Failure "Lm_list_util.remove_suffix") (* * Compare two lists of things. *) let rec compare_lists cmp l1 l2 = match (l1,l2) with h1::t1, h2::t2 -> let i = cmp h1 h2 in if i = 0 then compare_lists cmp t1 t2 else i | [], [] -> 0 | [], _ -> -1 | _ -> 1 let rec compare_cmp cmp l1 l2 = match l1, l2 with h1 :: t1, h2 :: t2 -> cmp h1 h2 && compare_cmp cmp t1 t2 | [], [] -> true | _ -> false let rec compare_eq l1 l2 = match l1, l2 with h1::t1, h2::t2 -> h1 == h2 && compare_eq t1 t2 | [], [] -> true | _ -> false (* * Get the nth item. *) let rec nth l i = if i <= 0 then raise (Failure "Lm_list_util.nth") else match l with _::t -> nth t (i - 1) | [] -> raise (Failure "Lm_list_util.nth") (* * Map a function over two lists. *) let rec map2 f l1 l2 = match (l1,l2) with h1::t1, h2::t2 -> let h = f h1 h2 in h :: map2 f t1 t2 | [], [] -> [] | _ -> raise (Failure "Lm_list_util.map2") let rec iter2 f al bl = match (al, bl) with h1::t1, h2::t2 -> f h1 h2; iter2 f t1 t2 | [], [] -> () | _ -> raise (Failure "Lm_list_util.iter2") let rec rev_iter2 f a b = match (a,b) with ([], []) -> () | (ha::ta, hb::tb) -> rev_iter2 f ta tb; f ha hb | _ -> raise (Failure "Lm_list_util.rev_iter2") (* * Test two lists. *) let rec for_all2 f l1 l2 = match (l1,l2) with h1::t1, h2::t2 -> f h1 h2 && for_all2 f t1 t2 | [], [] -> true | _ -> false (* * Exists a pair in the two lists. *) let rec exists2 f l1 l2 = match (l1,l2) with h1::t1, h2::t2 -> f h1 h2 || exists2 f t1 t2 | _ -> false (* * Fold left over two lists. *) let rec fold_left2 f x al bl = match (al, bl) with (h1::t1, h2::t2) -> fold_left2 f (f x h1 h2) t1 t2 | [], [] -> x | _ -> raise (Failure "Lm_list_util.fold_left2") let rec smap f = function [] -> [] | hd::tl as l -> let hd' = f hd in let tl' = smap f tl in if (hd == hd') && (tl == tl') then l else hd'::tl' (************************************************************************ * Association lists. *) let rec zip_list l l1 l2 = match (l1,l2) with (h1::t1), (h2::t2) -> zip_list ((h1,h2)::l) t1 t2 | [], [] -> l | _ -> raise (Failure "Lm_list_util.zip") (* * Zip two lists. Same as List.combine, but raises Failure instead of Invalid_argument *) let rec zip a b = match (a,b) with (h1::t1), (h2::t2) -> (h1, h2) :: zip t1 t2 | [], [] -> [] | _ -> raise (Failure "Lm_list_util.zip") (* * Produce a list of first elements out of the list of pairs *) let rec fst_split = function [] -> [] | (a, _) :: tl -> a :: fst_split tl (* * Apply a function to the key in an assoc list. *) let rec apply_assoc v l f = match l with (v', k) as h :: t -> if v' = v then (v', f k) :: t else h :: apply_assoc v t f | [] -> raise Not_found (* * Find index of association. *) let rec assoc_index_aux a i = function (a', _)::t -> if a' = a then i else assoc_index_aux a (i + 1) t | [] -> raise Not_found let assoc_index l a = assoc_index_aux a 0 l (* * Replace an association, but preserve order. *) let rec assoc_replace l a b = match l with (a', b')::t -> if a' = a then (a, b)::t else (a', b')::(assoc_replace t a b) | [] -> raise Not_found (* * Add the association if it doesn't already exist. *) let add_assoc (v1, v2) l = try let v2' = List.assoc v1 l in if v2 = v2' then l else raise (Failure "Lm_list_util.add_assoc") with Not_found -> (v1, v2)::l (* * See if a value is in domain. *) let rec assoc_in_dom eq y = function (y',_)::tl -> (eq y y') || (assoc_in_dom eq y tl) | [] -> false (* * See if a value is in range. *) let rec assoc_in_range eq y = function (_, y')::tl -> (eq y y') || (assoc_in_range eq y tl) | [] -> false let rec assoc_append_replace_snd l v = function [] -> l | (v', _) :: tl -> (v', v) :: (assoc_append_replace_snd l v tl) let rec check_assoc v v' = function [] -> v=v' | (v1,v2)::tl -> begin match v=v1, v'=v2 with true, true -> true | false, false -> check_assoc v v' tl | _ -> false end let rec try_check_assoc v v' = function [] -> raise Not_found | (v1,v2)::tl -> begin match v=v1, v'=v2 with true, true -> true | false, false -> try_check_assoc v v' tl | _ -> false end let rec try_assoc v = function [] -> v | (v1,v2)::tl -> if v1=v then v2 else try_assoc v tl (* * Association list with an equality. *) let rec assoc_eq eq x = function (x', y) :: t -> if eq x x' then y else assoc_eq eq x t | [] -> raise Not_found omake-0.10.3/src/libmojave/lm_thread_pool_system.ml0000644000175000017500000002111613177364666021024 0ustar gerdgerd(* * On Win32, select does not work on pipes. Instead, we use * threads to call all the handlers. We keep a thread pool. * When a thread makes progress, it wakes up the main process, * and returns to the pool. Each file descriptor is assigned * a thread. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2003-2007 Mojave Group, California Institute of Technology, and * HRL Laboratories, LLC * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey @email{jyh@cs.caltech.edu} * Modified By: Aleksey Nogin @email{anogin@hrl.com} * @end[license] *) open Lm_printf open Lm_debug open Lm_thread (* module Mutex = MutexDebug module Condition = ConditionDebug *) (* * Build debugging. *) let debug_thread = create_debug (**) { debug_name = "thread"; debug_description = "Display thread debugging"; debug_value = false } (* * Data structures. *) module IntCompare = struct type t = int let compare = (-) end module IntTable = Lm_map.LmMake (IntCompare) (* * Jobs are identified by descriptor. * If the job is not visible, it is not reported * to wait. *) type job = { job_id : int; job_fun : unit -> unit; job_visible : bool } (* * We keep a master lock: only one thread is allowed to run at * any given time. This doesn't really affect performance, * since OCaml enforces this restriction anyway. Note: the * threads should release the lock before they wait for I/O. *) type pool = { mutable pool_pid : int; mutable pool_size : int; mutable pool_members : Thread.t list; mutable pool_ready : job list; mutable pool_ready_length : int; mutable pool_running : job IntTable.t; mutable pool_finished : job list; mutable pool_break : bool; pool_finished_wait : Condition.t; pool_consumer_wait : Condition.t; pool_lock : Mutex.t } (* * The pool. *) let pool = { pool_pid = 1; pool_size = 0; pool_members = []; pool_ready = []; pool_ready_length = 0; pool_running = IntTable.empty; pool_finished = []; pool_break = false; pool_finished_wait = Condition.create (); pool_consumer_wait = Condition.create (); pool_lock = Mutex.create "Lm_thread_pool" } (* * Lock for the main thread. *) let () = Mutex.lock pool.pool_lock (* * Threads are enabled. *) let enabled = true (* * Temporarily unlock the pool while performing IO. * The check_status function may generate exceptions. *) let blocking_section f x = Mutex.unlock pool.pool_lock; try let y = f x in Mutex.lock pool.pool_lock; y with exn -> Mutex.lock pool.pool_lock; raise exn let resume_inner_section f x = Mutex.lock pool.pool_lock; try let y = f x in Mutex.unlock pool.pool_lock; y with exn -> Mutex.unlock pool.pool_lock; raise exn (* * Thread main loop. *) let thread_main_loop () = try let id = Thread.id (Thread.self ()) in if !debug_thread then eprintf "Thread %d: starting@." id; let _ = Thread.sigmask Unix.SIG_SETMASK [Sys.sigint; Sys.sigquit] in Mutex.lock pool.pool_lock; if !debug_thread then eprintf "Thread %d: entered main loop@." id; let rec loop () = match pool.pool_ready with job :: rest -> pool.pool_ready <- rest; pool.pool_ready_length <- pred pool.pool_ready_length; pool.pool_running <- IntTable.add pool.pool_running job.job_id job; if !debug_thread then eprintf "Thread %d: calling function: %d@." id job.job_id; (try job.job_fun () with Sys.Break -> if !debug_thread then eprintf "Lm_thread_pool_system: %d: Break@." job.job_id; pool.pool_break <- true; Condition.signal pool.pool_finished_wait | exn -> eprintf "Lm_thread_pool_system: thread raised exception: %s: %d@." (Printexc.to_string exn) job.job_id); pool.pool_running <- IntTable.remove pool.pool_running job.job_id; if job.job_visible then begin pool.pool_finished <- job :: pool.pool_finished; Condition.signal pool.pool_finished_wait end; if pool.pool_break then Mutex.unlock pool.pool_lock else loop () | [] -> if !debug_thread then eprintf "Thread %d: waiting@." id; Condition.wait pool.pool_consumer_wait pool.pool_lock; if !debug_thread then eprintf "Thread %d: waited@." id; if not pool.pool_break then loop () in loop () with Sys.Break -> pool.pool_break <- true; if !debug_thread then eprintf "Lm_thead_pool_system: break@."; Mutex.unlock pool.pool_lock; Condition.signal pool.pool_finished_wait; Condition.signal pool.pool_consumer_wait (* * Start a thread doing something. *) let create visible f = (* * XXX: TODO: we may want to support "restarting" a pool after it was killed * with a Ctrl-C, but for now the transition to pool_break state is a kiss of * death. *) if pool.pool_break then raise Sys.Break; let id = succ pool.pool_pid in let job = { job_id = id; job_fun = f; job_visible = visible } in pool.pool_pid <- id; pool.pool_ready <- job :: pool.pool_ready; pool.pool_ready_length <- succ pool.pool_ready_length; (* Enlarge the pool if needed *) if pool.pool_size < pool.pool_ready_length + IntTable.cardinal pool.pool_running then begin pool.pool_size <- succ pool.pool_size; if !debug_thread then eprintf "Starting a new worker thread, total worker threads: %d@." pool.pool_size; pool.pool_members <- (Thread.create thread_main_loop ()) :: pool.pool_members end; (* Wake up one of the waiters if they are waiting *) Condition.signal pool.pool_consumer_wait; if !debug_thread then eprintf "Create: %d@." id; id (* * Wait until something happens, and return the identifier of * all the threads that completed. *) let wait () = (* Wait until a thread finishes *) while pool.pool_finished = [] && not pool.pool_break do if !debug_thread then eprintf "Main: waiting: %d+%d@." pool.pool_ready_length (IntTable.cardinal pool.pool_running); Condition.wait pool.pool_finished_wait pool.pool_lock; if !debug_thread then eprintf "Main: waited@."; done; if pool.pool_break then raise Sys.Break; (* Return pids of all the threads that finished *) let pids = List.map (fun job -> job.job_id) pool.pool_finished in pool.pool_finished <- []; pids (* * Wait until a specific pid disappears. *) let waitpid id = (* Wait until a thread finishes *) while IntTable.mem pool.pool_running id && not pool.pool_break do if !debug_thread then eprintf "Main: waiting: %d+%d@." pool.pool_ready_length (IntTable.cardinal pool.pool_running); Condition.wait pool.pool_finished_wait pool.pool_lock; if !debug_thread then eprintf "Main: waited@."; done; if pool.pool_break then raise Sys.Break; (* * -*- * Local Variables: * End: * -*- *) omake-0.10.3/src/libmojave/lm_thread_core_system.ml0000644000175000017500000001503513177364666021006 0ustar gerdgerd(* * Our personal implementation of threads. Each thread has * thread-local state. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2003-2007 Mojave Group, California Institute of Technology, and * HRL Laboratories, LLC * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Authors: Jason Hickey @email{jyh@cs.caltech.edu} * Aleksey Nogin @email{anogin@hrl.com} * @end[license] *) open Lm_debug open Lm_printf module MutexCore = struct type t = Mutex.t let create _ = Mutex.create () let lock = Mutex.lock let try_lock = Mutex.try_lock let unlock = Mutex.unlock end module ConditionCore = struct type t = Condition.t type mutex = Mutex.t let create = Condition.create let wait = Condition.wait let signal = Condition.signal let broadcast = Condition.broadcast end (* * Thread implementation. *) module ThreadCore = struct type t = Thread.t type id = int type 'a result = Result of 'a | Exn of exn let enabled = true let create = Thread.create let self = Thread.self let id = Thread.id let join = Thread.join let sigmask = if Sys.os_type = "Win32" then (fun _ mask -> mask) else Thread.sigmask let raise_ctrl_c_wrapper f x = let running = ref true in let result = ref (Exn (Invalid_argument "Lm_thread_core.raise_ctrl_c_wrapper")) in let run () = begin try result := Result (f x); with exn -> result := Exn exn end; running := false in let rec wait () = if !running then begin Thread.delay 0.1; wait () end else match !result with Result res -> res | Exn exn -> raise exn in ignore (Thread.create run ()); wait () end let debug_mutex = create_debug (**) { debug_name = "mutex"; debug_description = "Show Mutex locking operations"; debug_value = false } module MutexCoreDebug = struct type t = { lock: Mutex.t; id : string; mutable locked: int option } let my_id () = Thread.id (Thread.self ()) let count = let count = ref 0 in let lock = Mutex.create () in fun () -> Mutex.lock lock; incr count; let res = !count in Mutex.unlock lock; res let create debug = { lock = Mutex.create (); id = sprintf "%s.%i" debug (count ()); locked = None } let try_lock l = let was_unlocked = Mutex.try_lock l.lock in if was_unlocked then begin begin match l.locked with None -> () | Some id -> if !debug_mutex then eprintf "!!! Lm_thread_core_system.MutexCore.lock: insonsistency! Thread %i found the lock %s unlocked, while we think it was locked by %i@." (my_id()) l.id id end; if !debug_mutex then eprintf "Mutex.[try_]lock: %i locked %s@." (my_id()) l.id; l.locked <- Some (my_id()) end; was_unlocked let lock l = if not (try_lock l) then begin let id = match l.locked with None -> "unknown" | Some i -> string_of_int i in if !debug_mutex then eprintf "Mutex.lock: %i will block on lock %s, held by %s@." (my_id()) l.id id; Mutex.lock l.lock; if !debug_mutex then eprintf "Mutex.lock: %i locked %s@." (my_id()) l.id; l.locked <- Some (my_id()) end let unlock l = begin match l.locked with None -> if !debug_mutex then eprintf "!!! Lm_thread_core_system.MutexCore.unlock: insonsistency! Thread %i unlocking %s, which is already unlocked@." (my_id()) l.id | Some id -> if id = (my_id()) then if !debug_mutex then eprintf "Mutex.unlock: %i unlocking %s@." (my_id()) l.id else if !debug_mutex then eprintf "!!! Lm_thread_core_system.MutexCore.unlock: insonsistency! Thread %i unlocking %s, which was locked by a different thread %i@." (my_id()) l.id id end; l.locked <- None; Mutex.unlock l.lock end module ConditionCoreDebug = struct open MutexCoreDebug type t = Condition.t type mutex = MutexCoreDebug.t let create = Condition.create let signal = Condition.signal let broadcast = Condition.broadcast let wait (cond:t) (l:mutex) = begin match l.locked with None -> if !debug_mutex then eprintf "!!! Lm_thread_core_system.ConditionCore.wait: insonsistency! Thread %i unlocking %s, which is already unlocked@." (my_id()) l.id | Some id -> if id = (my_id()) then if !debug_mutex then eprintf "Condition.wait: %i unlocking %s@." (my_id()) l.id else if !debug_mutex then eprintf "!!! Lm_thread_core_system.ConditionCore.wait: insonsistency! Thread %i unlocking %s, which was locked by a different thread %i@." (my_id()) l.id id end; l.locked <- None; Condition.wait cond l.lock; begin match l.locked with None -> () | Some id -> if !debug_mutex then eprintf "!!! Lm_thread_core_system.ConditionCore.wait: insonsistency! Thread %i receiving a lock %s, which is already locked by %i@." (my_id()) l.id id; end; l.locked <- Some (my_id()) end (* * -*- * Local Variables: * End: * -*- *) omake-0.10.3/src/libmojave/lm_thread_sig.ml0000644000175000017500000000636113177364666017236 0ustar gerdgerd(* * Our personal implementation of threads. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2003 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) module type MutexSig = sig type t val create : string -> t val lock : t -> unit val try_lock : t -> bool val unlock : t -> unit end module type ConditionSig = sig type t type mutex val create : unit -> t val wait : t -> mutex -> unit val signal : t -> unit val broadcast : t -> unit end (* * The "state" provides thread-local storage with * read and write locks. By default, all threads * share the same state. All elements that are * added are available in all threads, but * each thread may have a different value for * the element. * * The read and write functions are locked * using a fair readers-writers protocol. *) module type StateSig = sig type t type 'a entry (* State operations *) val create : unit -> t val current : unit -> t val set : t -> unit val with_state : t -> ('a -> 'b) -> 'a -> 'b (* Global variables *) val shared_val : string -> 'a -> 'a entry val private_val : string -> 'a -> ('a -> 'a) -> 'a entry val read : 'a entry -> ('a -> 'b) -> 'b val write : 'a entry -> ('a -> 'b) -> 'b val unlock : 'a entry -> (unit -> 'b) -> 'b (* This function is only valid within a lock *) val get : 'a entry -> 'a end module type ThreadSig = sig type t type id val enabled : bool val create : ('a -> 'b) -> 'a -> t val self : unit -> t val join : t -> unit val id : t -> int val sigmask : Unix.sigprocmask_command -> int list -> int list (* * XXX: This is a hack to address the "Sys.Break does not get raised inside * C blocking sections" problem. * See http://caml.inria.fr/pub/ml-archives/caml-list/2007/07/3662ad69f77253674f580b174c85dfbb.en.html for detail. * The (raise_ctrl_c_wrapper f x) behaves like (f x), except that it makes * sure that any Ctrl-C event quickly results in a Sys.Break exception, even * if f spends "forever" inside a C blocking section. *) val raise_ctrl_c_wrapper: ('a -> 'b) -> 'a -> 'b end (* * -*- * Local Variables: * End: * -*- *) omake-0.10.3/src/libmojave/lm_string_set.ml0000644000175000017500000000360213177364666017301 0ustar gerdgerd(* * Sets of strings. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2003 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) (* * String sets and string tables *) module OrderedString = struct type t = string let compare = Lm_string_util.string_compare end module StringSet = Lm_set.LmMake (OrderedString) module StringTable = Lm_map.LmMake (OrderedString) module StringMTable = Lm_map.LmMakeList (OrderedString) (* * String sets and string tables with lexicographical ordering. *) module LexOrderedString = struct type t = string let compare (s1: t) s2 = Pervasives.compare s1 s2 end module LexStringSet = Lm_set.LmMake (LexOrderedString) module LexStringTable = Lm_map.LmMake (LexOrderedString) module LexStringMTable = Lm_map.LmMakeList (LexOrderedString) (*! * @docoff * * -*- * Local Variables: * Caml-master: "compile" * End: * -*- *) omake-0.10.3/src/libmojave/lm_instrument.ml0000644000175000017500000000630713177364666017335 0ustar gerdgerd(* This file is (C) 2014 by Gerd Stolpmann. It is distributed under the same license conditions as OMake. It was developed with financial support from Lexifi. *) open Printf type probe = { probe_name : string; mutable probe_count : int; mutable probe_acc_time : float; mutable probe_self_time : float; mutable probe_min_time : float; mutable probe_max_time : float; mutable probe_invocations : int; mutable probe_recursive : bool; mutable probe_error : bool; } let enabled = ref false let registry = ref [] let create probe_name = let p = { probe_name; probe_count = 0; probe_acc_time = 0.0; probe_self_time = 0.0; probe_min_time = infinity; probe_max_time = 0.0; probe_invocations = 0; probe_recursive = false; probe_error = false; } in registry := p :: !registry; p let callstack = Stack.create() let start probe = if !enabled then ( let ts0 = Unix.gettimeofday() in if not (Stack.is_empty callstack) then ( let (top_probe, _, ts2) = Stack.top callstack in let t2 = ts0 -. ts2 in top_probe.probe_self_time <- top_probe.probe_self_time +. t2 ); probe.probe_invocations <- probe.probe_invocations + 1; Stack.push (probe, ts0, ts0) callstack ) let fst3 (x,_,_) = x let stop probe = if !enabled then ( let t0 = Unix.gettimeofday() in while not (Stack.is_empty callstack || fst3(Stack.top callstack) == probe) do let (p,_,_) = Stack.pop callstack in p.probe_error <- true; done; ( if Stack.is_empty callstack then probe.probe_error <- true else let (p,ts1,ts2) = Stack.pop callstack in assert(p == probe); let t1 = t0 -. ts1 in let t2 = t0 -. ts2 in probe.probe_invocations <- probe.probe_invocations - 1; probe.probe_count <- probe.probe_count + 1; probe.probe_self_time <- probe.probe_self_time +. t2; probe.probe_min_time <- min probe.probe_min_time t2; probe.probe_max_time <- max probe.probe_max_time t2; if probe.probe_invocations > 0 then probe.probe_recursive <- true else probe.probe_acc_time <- probe.probe_acc_time +. t1 ); if not (Stack.is_empty callstack) then ( let (p, ts1, _) = Stack.pop callstack in Stack.push (p, ts1, t0) callstack ) ) let finish() = Stack.iter (fun (p,_,_) -> p.probe_error <- true) callstack; Stack.clear callstack let instrument probe f arg = start probe; try let r = f arg in stop probe; r with error -> stop probe; raise error let report() = let all = List.rev !registry in printf "Probes (times in milliseconds):\n"; printf "%2s %-25s %9s %9s %9s %9s %9s\n" "FL" "NAME" "COUNT" "ACC" "SELF" "MIN" "MAX"; List.iter (fun p -> printf "%2s %-25s %9d %9.0f %9.0f %9.0f %9.0f\n" ( (if p.probe_recursive then "R" else " ") ^ (if p.probe_error then "E" else " ") ) p.probe_name p.probe_count (p.probe_acc_time *. 1000.0) (p.probe_self_time *. 1000.0) (p.probe_min_time *. 1000.0) (p.probe_max_time *. 1000.0) ) all; flush stdout omake-0.10.3/src/libmojave/lm_array_util.ml0000644000175000017500000001107213177364666017273 0ustar gerdgerd(* * Show the file loading. *) let _ = Lm_debug.show_loading "Loading Lm_array_util%t" (* * Boolean values. *) let all_true v = let rec search i len v = i = len || (v.(i) && search (succ i) len v) in search 0 (Array.length v) v let exists_true v = let rec search i len v = i <> len && (v.(i) || search (succ i) len v) in search 0 (Array.length v) v let for_all f v = let rec search f i len v = i = len || (f v.(i) && search f (succ i) len v) in search f 0 (Array.length v) v let for_all2 f a1 a2 = let len = Array.length a1 in Array.length a1 = Array.length a2 && (let rec apply i = (i = len) || (f a1.(i) a2.(i) && apply (i + 1)) in apply 0) (* * Membership in an array. *) let mem i v = let l = Array.length v in let rec aux j = j < l && ( i = v.(j) || aux (j + 1) ) in aux 0 (* * Membership in an array. *) let index i v = let l = Array.length v in let rec aux j = if j < l then if i = v.(j) then j else aux (j + 1) else raise Not_found in aux 0 (* * Membership in an array. *) let exists f v = let l = Array.length v in let rec aux j = j < l && ( f v.(j) || aux (j + 1) ) in aux 0 let find_index f v = let l = Array.length v in let rec aux j = if j < l then if f v.(j) then j else aux (j + 1) else raise Not_found in aux 0 (* * Iterate over two arrays. *) let iter2 f a1 a2 = let len = Array.length a1 in if Array.length a2 <> len then raise (Failure "Array.iter2") else let rec apply f a1 a2 i len = if i < len then begin f a1.(i) a2.(i); apply f a1 a2 (i + 1) len end in apply f a1 a2 0 len let append_list a = function [] -> a | hd :: tl -> let l = Array.length a in let res = Array.make (l + List.length tl + 1) hd in for i = 0 to pred l do Array.unsafe_set res i (Array.unsafe_get a i) done; let rec aux i = function [] -> res | hd :: tl -> Array.unsafe_set res i hd; aux (succ i) tl in aux (succ l) tl let append_list_array a1 l a2 = match l with [] -> Array.append a1 a2 | hd::tl -> let l1 = Array.length a1 and l2 = Array.length a2 in let offs = succ l1 + List.length tl in let res = Array.make (offs + l2) hd in for i = 0 to pred l1 do Array.unsafe_set res i (Array.unsafe_get a1 i) done; let rec aux i = function [] -> () | hd :: tl -> Array.unsafe_set res i hd; aux (succ i) tl in aux (succ l1) tl; for i = 0 to pred l2 do Array.unsafe_set res (i+offs) (Array.unsafe_get a2 i) done; res let replace a i j = function [] -> if j>0 then Array.append (Array.sub a 0 i) (Array.sub a (i+j) (Array.length a-i-j)) else raise (Invalid_argument "Lm_array_util.replace") | hd :: tl -> let l = Array.length a in let ij = i + j in if i>=0 && j>0 && ij<=l then let dl = List.length tl - j +1 in let res = Array.make (l+dl) hd in for k=0 to (pred i) do Array.unsafe_set res k (Array.unsafe_get a k) done; for k=ij to (pred l) do Array.unsafe_set res (k+dl) (Array.unsafe_get a k) done; let rec aux k = function [] -> res | hd :: tl -> Array.unsafe_set res k hd; aux (succ k) tl in aux (succ i) tl else raise (Invalid_argument "Lm_array_util.replace") (* * Map over a subarray. *) let sub_map f a i len = if i < 0 || len < 0 || i + len > Array.length a then raise (Invalid_argument "sub_map") else match len with 0 -> [||] | 1 -> [| f (Array.unsafe_get a i) |] | _ -> let a' = Array.make len (f (Array.unsafe_get a i)) in for j = 1 to len - 1 do Array.unsafe_set a' j (f (Array.unsafe_get a (i + j))) done; a' (* * Sorts an array, than eliminates the duplicate elements * and moves the remaining elements into an initial segment * of the input array. Returns the # of distinct elements. *) let distinct cmp = function [||] -> 0 | array -> let l = Array.length array in let rec d_find i = let j = (succ i) in if j = l then j else if (cmp array.(i) array.(j)) = 0 then d_copy i (succ j) else d_find j and d_copy i j = if j = l then succ i else if (cmp array.(i) array.(j)) = 0 then d_copy i (succ j) else let i = succ i in array.(i) <- array.(j); d_copy i (succ j) in Array.fast_sort cmp array; d_find 0 omake-0.10.3/src/libmojave/lm_thread_pool_null.ml0000644000175000017500000000435313177364666020456 0ustar gerdgerd(* * On Win32, select does not work on pipes. Instead, we use * threads to call all the handlers. We keep a thread pool. * When a thread makes progress, it wakes up the main process, * and returns to the pool. Each file descriptor is assigned * a thread. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2003-2005 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) open Lm_debug (* * Build debugging. *) let debug_thread = create_debug (**) { debug_name = "thread"; debug_description = "Display thread debugging"; debug_value = false } (* * Threads are not enabled. *) let enabled = false (* * Temporarily unlock the pool while performing IO. *) let blocking_section f x = f x let resume_inner_section f x = f x (* * Start a thread doing something. *) let create _ = raise (Invalid_argument "Lm_thread_pool_null.create: threads are not enabled") (* * Wait until something happens. *) let wait () = raise (Invalid_argument "Lm_thread_pool_null.wait: threads are not enabled") let waitpid _ = raise (Invalid_argument "Lm_thread_pool_null.waitpid: threads are not enabled") (*! * @docoff * * -*- * Local Variables: * Caml-master: "compile" * End: * -*- *) omake-0.10.3/src/libmojave/lm_thread_core_null.ml0000644000175000017500000000275613177364666020442 0ustar gerdgerdlet debug_mutex = Lm_debug.create_debug (**) { debug_name = "mutex"; debug_description = "Show Mutex locking operations"; debug_value = false } (* * Locks are not required when not using threads. * We only track the "locked" state to produce the correct results in the try_lock function. *) module MutexCore = struct (* true = free; false = locked *) type t = bool ref let create _ = ref true let lock l = l := false let try_lock l = let res = !l in l := false; res let unlock l = l := true end (* * Conditions are not required when not using threads. *) module ConditionCore = struct type t = unit type mutex = MutexCore.t let create () = () let wait _ l = l := false let signal () = () let broadcast () = () end (* module MutexCoreDebug = MutexCore *) (* module ConditionCoreDebug = ConditionCore *) (* * Threads are null. The create function doesn't work without * threads, so raise an exception. *) module ThreadCore = struct type t = unit type id = unit let enabled = false let create _f _x = raise (Invalid_argument "Lm_thread.Thread.create: threads are not enabled in this application") let join _t = raise (Invalid_argument "Lm_thread.Thread.join: threads are not enabled in this application") let self () = () let id () = 0 let sigmask _ mask = mask let raise_ctrl_c_wrapper f x = f x end omake-0.10.3/src/libmojave/lm_handle_table.mli0000644000175000017500000000016013177364666017667 0ustar gerdgerdtype 'a t type handle val create : unit -> 'a t val add : 'a t -> 'a -> handle val find : 'a t -> handle -> 'a omake-0.10.3/src/libmojave/lm_fs_case_sensitive.mli0000644000175000017500000000100213177364666020755 0ustar gerdgerd(* * Detection of filesystem case-sensitivity *) val available : bool val case_sensitive : string -> bool (* toggle the name and compare return true if their stat is not equal *) val stat_with_toggle_case : string -> string -> bool val check_already_lowercase : string -> int -> int -> unit exception Already_lowercase exception Not_a_usable_directory val dir_case_sensitive : string -> bool val dir_test_all_entries_exn : string -> Unix.dir_handle -> bool val dir_test_new_entry_exn : string -> bool omake-0.10.3/src/libmojave/lm_int_handle_table.mli0000644000175000017500000000065013177364666020545 0ustar gerdgerdtype handle type 'a t (* Handles *) val create_handle : 'a t -> int -> handle val new_handle : 'a t -> handle val int_of_handle : handle -> int (* Table *) val create : unit -> 'a t val add : 'a t -> handle -> 'a -> unit val remove : 'a t -> handle -> unit val find : 'a t -> handle -> 'a val find_any : 'a t -> handle -> 'a val find_any_handle : 'a t -> int -> handle val find_value : 'a t -> int -> 'a -> handle omake-0.10.3/src/libmojave/lm_filename_util.mli0000644000175000017500000000337113177364666020111 0ustar gerdgerd (* * Search for the index after the drive letter. *) type root = | NullRoot | DriveRoot of char type 'a path = | RelativePath of 'a | AbsolutePath of root * 'a (** Pathname separator chars. *) val separators : string val pathsep : string (* * Remove quotations from a string that represents a filename. *) val unescape_string : string -> string (* * Normalize function will give the canonical * lowercase name on Windows. It is a nop on * Unix. *) val normalize_string : string -> string val normalize_path : string list -> string list (* * A null root directory. *) val null_root : root (* * Get the root string. *) val string_of_root : root -> string (* * Skip the drive letter if it exists. *) val drive_skip : string -> int (* * Is this an absolute filename? *) val is_absolute : string -> bool (* * Parse filenames. *) val filename_string : string -> string path val filename_path : string -> string list path (* * Split into root, suffix. *) val split : string -> string * string (* * Get the name without suffix. *) val root : string -> string val suffix : string -> string val strip_suffixes : string -> string (* * Replace Filename. operations. *) val basename : string -> string val replace_basename : string -> string -> string (** Path simplification. Remove . and .. entries. *) type pathname = string list val split_path : string -> pathname val simplify_path : pathname -> pathname val concat_path : pathname -> string (* * Path searching. *) val is_executable : string -> string option val which : string -> string val which_dir : string -> string -> string val where : string -> string list (* * Make an entire hierarchy. *) val mkdirhier : string -> int -> unit omake-0.10.3/src/libmojave/lm_thread_pool.mli0000644000175000017500000000356413177364666017600 0ustar gerdgerd(* * Select doesn't work on Win32, so use threads instead. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2003-2005 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) (* * Debugging. *) val debug_thread : bool ref (* * Are threads enabled? *) val enabled : bool (* * Start a job in a new thread. * If the bool is false, the result is * not returned by wait when the thread exits. *) val create : bool -> (unit -> unit) -> int (* * When a job performs blocking IO, it should * unlock the main lock. *) val blocking_section : ('a -> 'b) -> 'a -> 'b val resume_inner_section : ('a -> 'b) -> 'a -> 'b (* * Wait for any of the jobs to complete. *) val wait : unit -> int list (* * Wait for a specific job to complete. *) val waitpid : int -> unit (*! * @docoff * * -*- * Local Variables: * Caml-master: "compile" * End: * -*- *) omake-0.10.3/src/libmojave/lm_thread_core.mli0000644000175000017500000000040013177364666017541 0ustar gerdgerd module MutexCore : Lm_thread_sig.MutexSig module ConditionCore : Lm_thread_sig.ConditionSig with type mutex = MutexCore.t module ThreadCore : Lm_thread_sig.ThreadSig (* * A debugging version that flags the errors. *) val debug_mutex: bool ref omake-0.10.3/src/libmojave/lm_string_util.mli0000644000175000017500000001573113177364666017642 0ustar gerdgerd(* * Faster comparison function for strings *) val string_compare : string -> string -> int (* * Check whether the string has a substring. * * equal_substring s1 off s2 * * Check whether s2 is a substring of s1 at offset off. * No exceptions raised. *) val equal_substring : string -> int -> string -> bool (* * Check whether the first string is a prefix of the second. *) val is_string_prefix : string -> string -> bool (* * Hex representation of a string. *) val unhex : char -> int val hexify : string -> string val hexify_sub : string -> int -> int -> string val unhexify : string -> string val unhexify_int : string -> int (* * Find a char in a string. *) val strchr : string -> char -> int (* * Membership. * contains s c : true iff c appears in s * contains_string s1 s2 : true iff any char in s2 appears in s1 *) val contains : string -> char -> bool val contains_any : string -> string -> bool (* * Standard definition of white space. *) val white : string val quotes : string (* * Mapping. *) val for_all : (char -> bool) -> string -> bool (* * Get the index of any char in the set. *) val index_set : string -> string -> int val rindex_set : string -> string -> int (* * Split a string into substrings. * The string is split on any character in delims. Empty substrings * are returned as empty strings in the list. For example: * split ".-" "foo.bar--ba??z" * returns * ["foo"; "bar"; ""; "ba??z"] *) val split : string -> string -> string list (* * Split a string based on a string delimiter. * For example: * split_string "ABC" "fooAB.ABCbar" * returns * ["fooAB."; "bar"] *) val split_string : string -> string -> string list (** raise Not_found *) val bi_split : char -> string -> (string * string) (* * Split a string based on a MIME string delimiter. * This is similar to the above, but the delimiter is * prefixed by a "--", and the 2 characters after the * delimiter are always dropped. * For example: * split_mime_string "ABC" "--ABC\r\nfooAB.--ABC\r\nbar--ABC--" * returns * ["fooAB."; "bar"] *) val split_mime_string : string -> string -> string list (* * Escape a string so that it can be read back in C. *) val c_escaped : string -> string (* * SQL uses a different convention. *) val sql_escaped : string -> string val mysql_escaped : string -> string (* * Escape a string so that it can be read back in Javascript. * This assumes single quotes. *) val js_escaped : string -> string val html_escaped : string -> string val html_pre_escaped : string -> string val html_escaped_nonwhite : string -> string (* * Unescape a string. Convert all escape sequences, * and remove outer double quotes. *) val unescape : string -> string (* * Test if a string is completely whitespace. *) val is_white : string -> bool (* * Split a string str into a list of substrings. * The string is split on any character in delims. Quotations * are not split. * * Empty substrings are _not_ returned as empty strings in the list. * For example: * tokens "" ".-" "foo.bar--ba??z" * returns * ["foo"; "bar"; "ba??z"] *) val tokens : string -> string -> string -> string list val tokens_std : string -> string list (* * Tokens_collect is an optimized form of token parsing * based on standard whitespace and quotes, and it * allows for incremental parsing. * * For example: * let buf = tokens_empty in * let tokens = tokens_string tokens " Foo \"bar \\" baz" in * let tokens = tokens_data tokens " a \"b c " in * let tokens = tokens_string tokens "boo\" bum" in * tokens_flush tokens * returns * ["Foo"; "\"bar \\" baz a \"b c boo\""; "a"] *) type 'a tokens val tokens_create_lexer : lexer : (string -> int -> int -> int option) -> wrap_string : (string -> 'a) -> wrap_data : (string -> 'a) -> wrap_token : (string -> 'a) -> group : ('a list -> 'a) -> 'a tokens val tokens_create : (string -> 'a) -> ('a list -> 'a) -> 'a tokens val tokens_string : 'a tokens -> string -> 'a tokens val tokens_lex : 'a tokens -> string -> 'a tokens val tokens_data : 'a tokens -> string -> 'a tokens val tokens_break : 'a tokens -> 'a tokens val tokens_add : 'a tokens -> 'a -> 'a tokens val tokens_atomic : 'a tokens -> 'a -> 'a tokens val tokens_flush : 'a tokens -> 'a list (* * A third way to split into substrings. * The tokens are separated by white space, * and tokens may be quoted. * * In the args_list case, the string lists are separated by \\ (AKA TeX "new line" command). *) val parse_args_list : string -> string list list val parse_args : string -> string list (* Add outer quotes to a string, and escape all the inner quotes. *) val shell_quotes : string -> string (* * Reconstruct an argv string from a list of strings. * The strings are concatenated with intervening whitespace. * If any of the strings contains whitespace or non-outermost * quotes, it is quoted, and inner quotes are escaped. *) val concat_argv : string list -> string (* * Construct a string from the list, separating by whitespace. * Quotes are added if the string contains special characters. *) val string_argv : string list -> string (* * Same as string_argv, but always quote the result. *) val quote_argv : string list -> string val quote_string : string -> string (* * Add a prefix to every string, and concatenate. *) val prepend : string -> string list -> string (* * Search for a pattern in the indicated buffer, within the start * and length constraints applied to the buffer. Note that this * uses a very inefficient algorithm; at some point I (JDS) will * get around to converting this to the Knuth-Morris-Pratt or * maybe Rabin-Karp algorithm. * * On success, this returns the offset (RELATIVE TO start!) of * the first match found; on failure, this raises Not_found. *) val strpat : string -> int -> int -> string -> int (* * Trim whitespace at outer boundaries from a string. *) val trim : string -> string (* * Trim all consecutive whitespace from a string, respecting * quotes. *) val trim_all : string -> string -> string -> string val trim_std : string -> string (* * Read the file into a string. * Raises Sys_error if the file can't be opened. *) val string_of_file : string -> string (* * Lm_debug versions of standard library. *) (* val create : string -> int -> string *) val make : string -> int -> char -> string val sub : string -> string -> int -> int -> string (* val blit : string -> string -> int -> string -> int -> int -> unit *) (* val set : string -> string -> int -> char -> unit *) val get : string -> string -> int -> char (* * Converting to-from the hex representation used in URI. *) val decode_hex_name : string -> string val encode_hex_name : string -> string val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a val fold_lefti : ('a -> int -> char -> 'a) -> 'a -> string -> 'a val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a val fold_righti : (int -> char -> 'a -> 'a) -> string -> 'a -> 'a val iteri : (int -> char -> 'a) -> string -> unit omake-0.10.3/src/libmojave/lm_string_set.mli0000644000175000017500000000325513177364666017456 0ustar gerdgerd(* * Sets of strings. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2003 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) open Lm_set_sig open Lm_map_sig (* * String environments. *) module StringSet : LmSet with type elt = string module StringTable : LmMap with type key = string module StringMTable : LmMapList with type key = string (* * String environments with lexicographical ordering. *) module LexStringSet : LmSet with type elt = string module LexStringTable : LmMap with type key = string module LexStringMTable : LmMapList with type key = string (*! * @docoff * * -*- * Local Variables: * Caml-master: "compile" * End: * -*- *) omake-0.10.3/src/libmojave/lm_instrument.mli0000644000175000017500000000134013177364666017476 0ustar gerdgerd(* This file is (C) 2014 by Gerd Stolpmann. It is distributed under the same license conditions as OMake. It was developed with financial support from Lexifi. *) type probe val enabled : bool ref (** Whether enabled (default: true) *) val create : string -> probe (** Create a new probe with this name *) val start : probe -> unit (** Start the probe timer *) val stop : probe -> unit (** Stop the probe timer *) val instrument : probe -> ('a -> 'b) -> 'a -> 'b (** [instrument p f arg]: run [f arg] and return the result (or exception). While running the runtime is measured. *) val finish : unit -> unit (** Globally finish all timers *) val report : unit -> unit (** Print a report to stdout *) omake-0.10.3/src/libmojave/lm_array_util.mli0000644000175000017500000000244613177364666017451 0ustar gerdgerd (* Membership in an array *) val mem : 'a -> 'a array -> bool val index : 'a -> 'a array -> int val find_index : ('a -> bool) -> 'a array -> int (* Raises Failure *) val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit (* Test boolean values *) val all_true : bool array -> bool val exists_true : bool array -> bool val for_all : ('a -> bool) -> 'a array -> bool val exists : ('a -> bool) -> 'a array -> bool (* Returns false if lengths mismatch *) val for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool (* * replace A i j B creates a copy of array A * where j elements with indices from i to i + j - 1 are * replaced with B's elements (if B has length different from j, * new array will have length different from A). * Raises invalid_argument if numbers out of range. *) val replace : 'a array -> int -> int -> 'a list -> 'a array val append_list : 'a array -> 'a list -> 'a array val append_list_array : 'a array -> 'a list -> 'a array -> 'a array (* * Map over a sub-array. *) val sub_map : ('a -> 'b) -> 'a array -> int -> int -> 'b array (* * Sorts an array, than eliminates the duplicate elements * and moves the remaining elements into an initial segment * of the input array. Returns the # of distinct elements. *) val distinct: ('a -> 'a -> int) -> 'a array -> int omake-0.10.3/src/libmojave/lm_db.mli0000644000175000017500000000252013177364666015654 0ustar gerdgerd(* * A simple database. This is a low-level ionterface. * See, for example, omake_db.ml to see a higher-level * interface. *) val debug_db : bool ref type t = Unix.file_descr type tag = int type magic = string type digest = string type hostname = string type named_value = string * string type entry_pred = tag -> named_value list -> hostname -> digest -> bool (* * Some kinds of entries are host-independent. *) type host = HostIndependent | HostDependent (* * These functions assume that the file is locked. * tag: the kind of entry * magic: the magic number for this version * digest: the source file digest (or use the empty string) * * These functions operate by side-effect, modifying the file. * add: remove the old entry and add a new one * find: find an existing entry, or raise Not_found if it doesn't exist * remove: remove an old entry, does not fail. *) val add : t -> string -> tag * host -> magic -> digest -> 'a -> unit val find : t -> string -> tag * host -> magic -> digest -> 'a val remove : t -> string -> tag * host -> magic -> unit (* * Somewhat more general interface. *) val first_entry_tag : tag val append_entry : t -> string -> tag -> named_value list -> digest -> 'a -> unit val find_entry : t -> string -> entry_pred -> 'a val remove_entry : t -> string -> entry_pred -> unit omake-0.10.3/src/libmojave/lm_map.mli0000644000175000017500000000124013177364666016042 0ustar gerdgerd(* Map module based on red-black trees *) open Lm_map_sig module Make (Ord : OrderedType) : (S with type key = Ord.t) module LmMake (Ord : OrderedType) : (LmMap with type key = Ord.t) module LmMakeList (Ord : OrderedType) : (LmMapList with type key = Ord.t) (* * This version includes a sharing constraint so that maps can * be used in recursive definitions. This exposes the internal * representation, should you should avoid using it unless * absolutely necessary (like in a recursive type definition). *) type ('key, 'value) tree module LmMakeRec (Ord : OrderedType) : (LmMap with type key = Ord.t with type 'a t = (Ord.t, 'a) tree) omake-0.10.3/src/libmojave/lm_set.mli0000644000175000017500000000024413177364666016063 0ustar gerdgerdopen Lm_set_sig module LmMake (Ord : OrderedType) : (LmSet with type elt = Ord.t) module LmMakeDebug (Ord : OrderedTypeDebug) : (LmSetDebug with type elt = Ord.t) omake-0.10.3/src/libmojave/lm_arg.mli0000644000175000017500000000362513177364666016047 0ustar gerdgerd(* * Parsing command line arguments, MCC-style. Arguments to options * may be separated from the option by a space, or may be placed * immediately after the option (without space) IF the option is * not ambiguous. Also, options may be abbreviated as long as the * short form is not ambiguous. * *) type 'a poly_spec = (* Non-folding versions *) | Unit of (unit -> unit) | Set of bool ref | Clear of bool ref | String of (string -> unit) | Int of (int -> unit) | Float of (float -> unit) | Rest of (string -> unit) (* Folding versions *) | UnitFold of ('a -> 'a) | SetFold of ('a -> bool -> 'a) | ClearFold of ('a -> bool -> 'a) | StringFold of ('a -> string -> 'a) | IntFold of ('a -> int -> 'a) | FloatFold of ('a -> float -> 'a) | RestFold of ('a -> string -> 'a) (* Usage message *) | Usage (* spec_mode StrictOptions: options are processed literally, and may not be collapsed into multi-letter options. MultiLetterMode: single-letter options of the form -x may be collapsed into multi-letter options. *) type spec_mode = StrictOptions | MultiLetterOptions type 'a poly_section = (string * 'a poly_spec * string) list type 'a poly_sections = spec_mode * (string * 'a poly_section) list type spec = unit poly_spec type section = unit poly_section type sections = unit poly_sections exception BogusArg of string exception UsageError (* * Folding versions. *) val fold_argv : string array -> 'a poly_sections -> 'a -> ('a -> string -> 'a * bool) -> string -> 'a val fold : 'a poly_sections -> 'a -> ('a -> string -> 'a * bool) -> string -> 'a (* * Non-folding versions. *) val parse_argv : string array -> sections -> (string -> unit) -> string -> unit val parse : sections -> (string -> unit) -> string -> unit (* * Usage string doesn't care. *) val usage : 'a poly_sections -> string -> unit omake-0.10.3/src/libmojave/lm_hash.mli0000644000175000017500000000507713177364666016224 0ustar gerdgerd (** Marshalable version. This takes a slightly different approach, wrapping the value in a triple of a hash code and a dummy ref cell. During marshaling, the cell will point somewhere else, so we know that the value must be reinterned. The hash codes are preseved across marshaling. BUG: we break abstraction here a little because it is hard to define the type recursively otherwise. *) module type MARSHAL = sig type t (* For debugging *) val debug : string (* The client needs to provide hash and comparison functions *) val hash : t -> int val compare : t -> t -> int val reintern : t -> t end module type MARSHAL_EQ = sig type t (* For debugging *) val debug : string (* * The client needs to provide the hash and the two comparison functions. *) val fine_hash : t -> int val fine_compare : t -> t -> int val coarse_hash : t -> int val coarse_compare : t -> t -> int (* Rehash the value *) val reintern : t -> t end (* * This is what we get. *) module type HashMarshalSig = sig type elt type t (* Creation *) val create : elt -> t (* Destructors *) val get : t -> elt val hash : t -> int (* Comparison *) val equal : t -> t -> bool val compare : t -> t -> int (* Rehash the value *) val reintern : t -> t end module type HashMarshalEqSig = sig include HashMarshalSig (* The default equality is the coarse one *) val fine_hash : t -> int val fine_compare : t -> t -> int val fine_equal : t -> t -> bool end module MakeCoarse (Arg : MARSHAL) : HashMarshalSig with type elt = Arg.t (** A variant with two equalities (see Lm_hash_sig for detail) Here we assume that the argument type has two notions of equality: - A strong equality ("idenitity"). Two strongly equal items are considered identical and should be coalesced during cons-hashing. - A weak equality ("equivalence"). The weakly equal items should be considered equivalent for the purposes of sets and tables, but they may have some individual representational characteristics that should be preserved. An example of this is filenames on case-insensitive case-preserving filesystems. Here the strong equality is the normal string equality (ensures case preservation) and the weak equality is the equality of the canonical (e.g. lowercase) representations (ensures case insensitivity). *) module MakeFine (Arg : MARSHAL_EQ) : HashMarshalEqSig with type elt = Arg.t val pp_print_stats : Format.formatter -> unit omake-0.10.3/src/libmojave/lm_wild.mli0000644000175000017500000000145013177364666016227 0ustar gerdgerd(* * Wildcard string. *) val wild_string : string (* * Wildcard matching. "Incoming" patterns must have exactly one instance * of the pattern symbol %. "Outgoing" patterns may have any number. *) type in_patt = private int * string * int * string type out_patt = private string list type subst = private int * string val pp_print_wild_in : in_patt Lm_printf.t val pp_print_wild_out : out_patt Lm_printf.t val is_wild : string -> bool val compile_in : string -> in_patt val compile_out : string -> out_patt (** {[ wild_match (compile_in "xx%yyzu") "xx1234yyzu";; Some (4, "1234") ]} *) val wild_match : in_patt -> string -> subst option val core : subst -> string val of_core : string -> subst val subst_in : subst -> in_patt -> string val subst : subst -> out_patt -> string omake-0.10.3/src/libmojave/lm_heap.mli0000755000175000017500000000243113177364666016210 0ustar gerdgerd(* * For heap debugging. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2006 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) val heap_check : string -> unit (* * -*- * Local Variables: * Fill-column: 100 * End: * -*- * vim:ts=3:et:tw=100 *) omake-0.10.3/src/libmojave/lm_uname.mli0000644000175000017500000000015713177364666016400 0ustar gerdgerdval sysname : string val nodename : string val release : string val version : string val machine : string omake-0.10.3/src/libmojave/lm_debug.mli0000644000175000017500000000256013177364666016361 0ustar gerdgerd(* * Info about debug variables. * The variables themselves are defined in the Lm_debug module. *) type debug_info = { debug_name : string; debug_description : string; debug_value : bool } (* if "load" debug is true, `show_load (s ^ "%t")' will print s to stderr and flush stderr *) val show_loading : ((out_channel -> unit) -> unit, out_channel, unit) format -> unit val debug : bool ref -> bool (* * We create named debug variables. *) val create_debug : debug_info -> bool ref (* * Operations to inspect debug flags. *) (* val debug_usage : unit -> unit *) (* * We allow flags to be set from the environment. * they may be set before the vars are created, * so we add them as "possible" debug flags, * then check them later. *) (* val set_possible_debug : string -> bool -> unit *) (* val check_debug : unit -> unit *) (* * Interface with Arg module. *) (* val set_debug_flags : string -> unit *) (* * Helper function for ad-hoc profiling. (timing_wrap s f x) computes (f x) * keeping track of the time it took to do it and collects the statistics * indexed by s. * report_timing prints out the statistics collected so far. This function * will be called automatically at function exit. * * Warning: timing_wrap is currently not threads-safe. *) (* val timing_wrap : string -> ('a -> 'b) -> 'a -> 'b *) (* val report_timing : unit -> unit *) omake-0.10.3/src/libmojave/lm_index.mli0000644000175000017500000001150213177364666016376 0ustar gerdgerd(* * Index module based on tables. * An index is essentially a multi-level table. * Each entry has an associated data item and subtable. * * ---------------------------------------------------------------- * * Copyright (C) 2002 Michael Maire, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Michael Maire * mmaire@caltech.edu * * ---------------------------------------------------------------- * Revision History * * 2002 Apr 20 Michael Maire Initial Version * 2002 Apr 25 Michael Maire Renamed iter, maps, folds to *_all * added single level iters, maps, folds * 2002 Apr 26 Michael Maire Added functions for explicitly adding * subindices * 2002 May 1 Michael Maire Changed interface for managing * subindices *) (* * Elements. * This type specifies the type of the keys used in the index. *) module type OrderedType = sig type t val compare : t -> t -> int end (* * These are the functions provided by the index. *) module type LmIndex = sig (* index maps key lists to elements of type 'a *) type key type 'a t (* empty index and empty test *) val empty : 'a t val is_empty : 'a t -> bool (* tests/lookups - single level*) val mem : 'a t -> key -> bool val find : 'a t -> key -> 'a t * 'a val find_index : 'a t -> key -> 'a t val find_data : 'a t -> key -> 'a (* tests/lookups - multi level*) val mem_list : 'a t -> key list -> bool val find_list : 'a t -> key list -> 'a t * 'a val find_list_index : 'a t -> key list -> 'a t val find_list_data : 'a t -> key list -> 'a (* addition and removal - single level*) val add : 'a t -> key -> 'a -> 'a t val add_i : 'a t -> key -> 'a t * 'a -> 'a t val remove : 'a t -> key -> 'a t (* addition of a chain of nested entries *) val add_list : 'a t -> key list -> 'a list -> 'a t val add_list_i : 'a t -> key list -> ('a t * 'a) list -> 'a t (* addition/removal of single entries *) val add_entry : 'a t -> key list -> 'a -> 'a t val add_entry_i : 'a t -> key list -> 'a t * 'a -> 'a t val remove_entry : 'a t -> key list -> 'a t (* filter addition/removal - single level *) val filter_add : 'a t -> key -> ('a option -> 'a) -> 'a t val filter_add_i : 'a t -> key -> (('a t * 'a) option -> ('a t * 'a)) -> 'a t val filter_remove : 'a t -> key -> ('a -> 'a option) -> 'a t val filter_remove_i : 'a t -> key -> (('a t * 'a) -> ('a t * 'a) option) -> 'a t (* filter addition of a chain of nested entries *) val filter_add_list : 'a t -> key list -> ('a option -> 'a) list -> 'a t val filter_add_list_i : 'a t -> key list -> (('a t * 'a) option -> ('a t * 'a)) list -> 'a t (* filter addition/removal of single entries *) val filter_add_entry : 'a t -> key list -> ('a option -> 'a) -> 'a t val filter_add_entry_i : 'a t -> key list -> (('a t * 'a) option -> ('a t * 'a)) -> 'a t val filter_remove_entry : 'a t -> key list -> ('a -> 'a option) -> 'a t val filter_remove_entry_i : 'a t -> key list -> (('a t * 'a) -> ('a t * 'a) option) -> 'a t (* iterators, maps, and folds - single level *) val iter : (key -> ('a t * 'a) -> unit) -> 'a t -> unit val map : (('a t * 'a) -> ('b t * 'b)) -> 'a t -> 'b t val mapi : (key -> ('a t * 'a) -> ('b t * 'b)) -> 'a t -> 'b t val fold : ('a -> key -> ('b t * 'b) -> 'a) -> 'a -> 'b t -> 'a val fold_map : ('a -> key -> ('b t * 'b) -> 'a * ('c t * 'c)) -> 'a -> 'b t -> 'a * 'c t (* iterators, maps, and folds - entire index *) val iter_all : (key list -> 'a -> unit) -> 'a t -> unit val map_all : ('a -> 'b) -> 'a t -> 'b t val mapi_all : (key list -> 'a -> 'b) -> 'a t -> 'b t val fold_all : ('a -> key list -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold_map_all : ('a -> key list -> 'b -> 'a * 'c) -> 'a -> 'b t -> 'a * 'c t end (* * Make the index. *) module LmMake (Ord : OrderedType) : (LmIndex with type key = Ord.t) omake-0.10.3/src/libmojave/lm_thread.mli0000644000175000017500000000041113177364666016533 0ustar gerdgerdopen Lm_thread_sig module Mutex : MutexSig module Condition : ConditionSig with type mutex = Mutex.t module Thread : ThreadSig module State : StateSig val debug_lock : bool ref module Synchronize : sig val synchronize : ('a -> 'b) -> 'a -> 'b end omake-0.10.3/src/libmojave/lm_notify.mli0000644000175000017500000000166313177364666016606 0ustar gerdgerd (* * Event manager. *) type t (* * Events. *) type code = |Changed | Deleted | StartExecuting | StopExecuting | Created | Moved | Acknowledge | Exists | EndExist | DirectoryChanged type event = { notify_code : code; notify_name : string } (* * Debugging. *) val debug_notify : bool ref val string_of_code : code -> string (* * Methods. *) val enabled : bool val create : unit -> t val close : t -> unit val file_descr : t -> Unix.file_descr option val monitor : t -> string -> bool -> unit val pending : t -> bool val next_event : t -> event val suspend : t -> string -> unit val resume : t -> string -> unit val cancel : t -> string -> unit val suspend_all : t -> unit val resume_all : t -> unit val cancel_all : t -> unit (* * -*- * Local Variables: * End: * -*- *) omake-0.10.3/src/libmojave/lm_symbol.mli0000644000175000017500000000304513177364666016577 0ustar gerdgerd(** Right now the symbol table is just a representation of strings. Representation of symbols. *) type t (* * Debugging adds extra qualifiers to new symbols. *) val debug_symbol : bool ref (* * An "empty" variable name *) val empty_var : t (** Add a symbol to the table. {[ Lm_symbol.add "_xyy32";; - : Lm_symbol.t = (32,_xyy) ]} *) val add : string -> t val make : string -> int -> t val is_interned : t -> bool val is_numeric_symbol : t -> bool val new_symbol : t -> t val new_symbol_pre : string -> t -> t val new_symbol_string : string -> t val to_int : t -> int val to_string : t -> string (* * Find a symbol for which the predicate is false. *) val new_name : t -> (t -> bool) -> t (* val new_name_gen : t -> (t -> 'a option) -> 'a *) (* * Get back the string. *) val string_of_symbol : t -> string val string_of_ext_symbol : t -> string val hash : t -> int val eq : t -> t -> bool val compare : t -> t -> int (* * This table provides associations between symbols * and values. *) module SymbolSet : Lm_set_sig.LmSet with type elt = t module SymbolTable : Lm_map_sig.LmMap with type key = t module SymbolMTable : Lm_map_sig.LmMapList with type key = t module SymbolIndex : Lm_index.LmIndex with type key = t val output_symbol : t Lm_printf.t val pp_print_symbol : t Lm_printf.t val dump_symbol : t Lm_printf.t val pp_print_ext_symbol : t Lm_printf.t val output_symbol_list : t list Lm_printf.t val output_symbol_set : SymbolSet.t Lm_printf.t val pp_print_method_name : t list Lm_printf.t omake-0.10.3/src/libmojave/lm_bitset.mli0000644000175000017500000000030713177364666016562 0ustar gerdgerd(* This is for VERY SMALL bitsets only that fit into a few machine words *) type t val create : unit -> t val is_set : t -> int -> bool val set : t -> int -> t val set_multiple : t -> int list -> t omake-0.10.3/src/libmojave/lm_printf.mli0000644000175000017500000001354213177364666016577 0ustar gerdgerd (** * For now, just use normal output channels. * Type t of buffers. *) type 'a t = Format.formatter -> 'a -> unit val open_out : string -> Format.formatter val open_out_bin : string -> Format.formatter (* * These functions are bad style for functional programs. *) val prerr_char : char -> unit val prerr_int : int -> unit val prerr_string : string -> unit (* * Flush the output. *) val flush : Format.formatter -> unit val eflush : Format.formatter -> unit (* * Printing. *) val eprintf : ('a, Format.formatter, unit) format -> 'a val printf : ('a, Format.formatter, unit) format -> 'a val sprintf : ('a, unit, string) format -> 'a val fprintf : Format.formatter -> ('a, Format.formatter, unit) format -> 'a val bprintf : Buffer.t -> ('a, Format.formatter, unit) format -> 'a (* * List printing helpers. *) val print_any_list : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit val print_string_list : Format.formatter -> string list -> unit val print_int_list : Format.formatter -> int list -> unit (************************************************************************ * Formatter interface. *) (* * Boxes. *) val open_box : int -> unit val open_vbox : int -> unit val open_hbox : unit -> unit val open_hvbox : int -> unit val open_hovbox : int -> unit val close_box : unit -> unit (* * Formatting functions. *) val print_string : string -> unit val print_as : int -> string -> unit val print_int : int -> unit val print_float : float -> unit val print_char : char -> unit val print_bool : bool -> unit (* * Break hints. *) val print_space : unit -> unit val print_cut : unit -> unit val print_break : int -> int -> unit val print_flush : unit -> unit val print_newline : unit -> unit val force_newline : unit -> unit val print_if_newline : unit -> unit (* * Margin. *) val set_margin : int -> unit val get_margin : unit -> int (* * Indentation limit. *) val set_max_indent : int -> unit val get_max_indent : unit -> int (* * Formatting depth. *) val set_max_boxes : int -> unit val get_max_boxes : unit -> int val over_max_boxes : unit -> bool (* * Tabulations. *) val open_tbox : unit -> unit val close_tbox : unit -> unit val print_tbreak : int -> int -> unit val set_tab : unit -> unit val print_tab : unit -> unit (* * Ellipsis. *) val set_ellipsis_text : string -> unit val get_ellipsis_text : unit -> string (* * Redirecting formatter output. *) val set_formatter_out_channel : Pervasives.out_channel -> unit val set_formatter_output_functions : (string -> int -> int -> unit) -> (unit -> unit) -> unit val get_formatter_output_functions : unit -> (string -> int -> int -> unit) * (unit -> unit) val get_all_formatter_output_functions : unit -> (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) * (int -> unit) (* * Multiple formatted output. *) type formatter = Format.formatter val formatter_of_out_channel : Pervasives.out_channel -> formatter val std_formatter : formatter val err_formatter : formatter val str_formatter : formatter val stdbuf : Buffer.t val flush_str_formatter : unit -> string val formatter_of_buffer : Buffer.t -> formatter val make_formatter : (string -> int -> int -> unit) -> (unit -> unit) -> formatter val byte_formatter : (bytes -> int -> int -> unit) -> (unit -> unit) -> formatter val pp_open_hbox : formatter -> unit -> unit val pp_open_vbox : formatter -> int -> unit val pp_open_hvbox : formatter -> int -> unit val pp_open_hovbox : formatter -> int -> unit val pp_open_box : formatter -> int -> unit val pp_close_box : formatter -> unit -> unit val pp_print_string : formatter -> string -> unit val pp_print_as : formatter -> int -> string -> unit val pp_print_int : formatter -> int -> unit val pp_print_float : formatter -> float -> unit val pp_print_char : formatter -> char -> unit val pp_print_bool : formatter -> bool -> unit val pp_print_break : formatter -> int -> int -> unit val pp_print_cut : formatter -> unit -> unit val pp_print_space : formatter -> unit -> unit val pp_force_newline : formatter -> unit -> unit val pp_print_flush : formatter -> unit -> unit val pp_print_newline : formatter -> unit -> unit val pp_print_if_newline : formatter -> unit -> unit val pp_open_tbox : formatter -> unit -> unit val pp_close_tbox : formatter -> unit -> unit val pp_print_tbreak : formatter -> int -> int -> unit val pp_set_tab : formatter -> unit -> unit val pp_print_tab : formatter -> unit -> unit val pp_set_margin : formatter -> int -> unit val pp_get_margin : formatter -> unit -> int val pp_set_max_indent : formatter -> int -> unit val pp_get_max_indent : formatter -> unit -> int val pp_set_max_boxes : formatter -> int -> unit val pp_get_max_boxes : formatter -> unit -> int val pp_over_max_boxes : formatter -> unit -> bool val pp_set_ellipsis_text : formatter -> string -> unit val pp_get_ellipsis_text : formatter -> unit -> string val pp_set_formatter_out_channel : formatter -> Pervasives.out_channel -> unit val pp_set_formatter_output_functions : formatter -> (string -> int -> int -> unit) -> (unit -> unit) -> unit val pp_get_all_formatter_output_functions : formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) * (int -> unit) (* Prints a "; "- separated list. *) val pp_print_any_list : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit omake-0.10.3/src/libmojave/lm_marshal.mli0000644000175000017500000000204613177364666016721 0ustar gerdgerdtype 'a item = | Bool of bool | Char of char | Code of int | Symbol of int | Int of int | Magic of 'a | Float of float | String of string | List of 'a item list type magic = | LocationMagic | IdMagic | NullRootMagic | DriveRootMagic | DirRootMagic | DirSubMagic | NodeFileMagic | NodePhonyGlobalMagic | NodePhonyDirMagic | NodePhonyFileMagic | NodeFlaggedMagic | NodeIsOptionalMagic | NodeIsExistingMagic | NodeIsSquashedMagic | NodeIsScannerMagic | QuietFlagMagic | AllowFailureFlagMagic | AllowOutputFlagMagic | CommandLineMagic | PrintEagerMagic | PrintLazyMagic | PrintExitMagic | RequestSpawnMagic | ResponseCreateMagic | ResponseExitedMagic | ResponseStdoutMagic | ResponseStderrMagic | MaxMagic | ResponseStatusMagic type msg = magic item exception MarshalError val marshal_string_list : string list -> 'a item val unmarshal_string_list : 'a item -> string list val marshal_loc : Lm_location.t -> magic item val unmarshal_loc : magic item -> Lm_location.t omake-0.10.3/src/libmojave/lm_int_set.mli0000644000175000017500000000025113177364666016733 0ustar gerdgerdmodule IntSet : Lm_set_sig.LmSet with type elt = int module IntTable : Lm_map_sig.LmMap with type key = int module IntMTable : Lm_map_sig.LmMapList with type key = int omake-0.10.3/src/libmojave/lm_channel.mli0000644000175000017500000000522713177364666016706 0ustar gerdgerd type channel type t = channel (* * The channel may be a file, pipe, or socket. *) type kind = | FileChannel | PipeChannel | SocketChannel type mode = | InChannel | OutChannel | InOutChannel (* Creation *) val create : string -> kind -> mode -> bool -> Unix.file_descr option -> t val name : t -> string val descr : t -> Unix.file_descr val close : t -> unit val info : t -> int * kind * mode * bool val set_id : t -> int -> unit val of_string : string -> t val of_substring : string -> int -> int -> t val of_loc_string : string -> int -> int -> string -> t val of_fun : (bytes -> int -> int -> int) -> (bytes -> int -> int -> int) -> t (* Output to strings *) val create_string : unit -> t val create_loc_string : string -> int -> int -> t val to_string : t -> string (* Set the file and line number *) val set_line : t -> string -> int -> unit (* * Set text vs binary mode. * No effect unless on Win32. *) val set_binary_mode : t -> bool -> unit (* The write function is arbitrary and can be replaced *) val set_io_functions : t -> (bytes -> int -> int -> int) -> (* Reader *) (bytes -> int -> int -> int) -> (* Writer *) unit (* Positioning *) val tell : t -> int val seek : t -> int -> Unix.seek_command -> int val loc : t -> Lm_location.t (* Check if there is already input in the buffer *) val poll : t -> bool (* Buffered IO *) val input_char : t -> char val input_byte : t -> int val input_buffer : t -> bytes -> int -> int -> unit val input_line : t -> string val input_entire_line : t -> string val read : t -> bytes -> int -> int -> int (* Flush data to the channel *) val flush : t -> unit (* Buffered IO *) val output_char : t -> char -> unit val output_byte : t -> int -> unit val output_buffer : t -> bytes -> int -> int -> unit val output_string : t -> string -> unit val write : t -> bytes -> int -> int -> int (* Select *) val select : t list -> t list -> t list -> float -> t list * t list * t list (* Lex-mode operations *) module LexerInput : sig type t = channel val lex_start : t -> int val lex_restart : t -> int -> unit val lex_stop : t -> int -> unit val lex_string : t -> int -> string val lex_substring : t -> int -> int -> string val lex_next : t -> int val lex_pos : t -> int val lex_buffer : t -> Buffer.t -> unit val lex_loc : t -> int -> Lm_location.t val bof : int val eof : int end (*! * @docoff * * -*- * Local Variables: * Caml-master: "compile" * End: * -*- *) omake-0.10.3/src/libmojave/lm_termsize.mli0000644000175000017500000000025513177364666017134 0ustar gerdgerd open Unix val term_size : file_descr -> int * int val min_screen_width : int ref val term_width : out_channel -> int -> int val stdout_width : int val stderr_width : int omake-0.10.3/src/libmojave/lm_terminfo.mli0000644000175000017500000000125713177364666017120 0ustar gerdgerd (* tgetstr id Lookup the terminal capability with indicated id. This assumes the terminfo to lookup is given in the TERM environment variable. This function returns None if the terminal capability is not defined. *) val tgetstr : string -> string option (* Various terminfo identifier names for use with tgetstr *) val enter_bold_mode : string val exit_attribute_mode : string (* xterm_escape_begin () Display XTerm title begin escape, if available. *) val xterm_escape_begin : unit -> string option (* xterm_escape_begin () Display XTerm title end escape, if available. *) val xterm_escape_end : unit -> string option val get_number_of_cores : unit -> int omake-0.10.3/src/libmojave/lm_location.mli0000644000175000017500000000116213177364666017100 0ustar gerdgerd(* * Source file tations. *) type t (* * Comparison. *) val compare : t -> t -> int (* * Don't use this if you can avoid it. *) val bogus_loc : string -> t (* * This is the normal way to make a tation. * filename, start_line, start_char, end_line, end_char *) val create_loc : Lm_symbol.t -> int -> int -> int -> int -> t (* * For marshaling. *) val dest_loc : t -> Lm_symbol.t * int * int * int * int (* * Combine two tations. * The resulting span covers both. *) val union_loc : t -> t -> t (* * Print a file tation. *) val pp_print_location : t Lm_printf.t val string_of_location : t -> string omake-0.10.3/src/libmojave/lm_readline.mli0000644000175000017500000000077513177364666017064 0ustar gerdgerd val flush : unit -> unit val isatty : unit -> bool val readline : string -> string val readstring : string -> string -> int -> int -> int val set_interactive : bool -> unit val is_interactive : unit -> bool val where : unit -> int val history : unit -> string array val load : string -> unit val save : unit -> unit val set_length : int -> unit val set_directory : string -> unit val prompt_invisible: (string * string) option omake-0.10.3/src/libmojave/lm_position.mli0000644000175000017500000000226513177364666017141 0ustar gerdgerd val debug_pos : bool ref val trace_pos : bool ref (* * Lm_position information. *) type 'a pos (* * Module for creating positions. * You have to specify the name of the module * where the exception are being created: use * MakePos in each file where Name.name is set * to the name of the module. *) module MakePos (Name : sig type t (* This is the name of the module where the position info is created *) val name : string (* Utilities for managing values *) val loc_of_t : t -> Lm_location.t val pp_print_t : t Lm_printf.t end ) : sig type t = Name.t (* Creating positions *) val loc_exp_pos : Lm_location.t -> t pos val loc_pos : Lm_location.t -> t pos -> t pos val base_pos : t -> t pos val cons_pos : t -> t pos -> t pos val pos_pos : t pos -> t pos -> t pos val int_pos : int -> t pos -> t pos val string_pos : string -> t pos -> t pos val symbol_pos : Lm_symbol.t -> t pos -> t pos val del_pos : (Format.formatter -> unit) -> Lm_location.t -> t pos val del_exp_pos : (Format.formatter -> unit) -> t pos -> t pos (* Utilities *) val loc_of_pos : t pos -> Lm_location.t val pp_print_pos : t pos Lm_printf.t end omake-0.10.3/src/libmojave/lm_unix_util.mli0000644000175000017500000000361613177364666017316 0ustar gerdgerd val pp_time : float Lm_printf.t (* Print the location of the stack pointer for debugging. *) (* val print_stack_pointer : unit -> unit *) (* * Location of application data (this is the same as home_dir * except on Win32). *) val application_dir : string (* * Really read some number of bytes. *) val really_read : Unix.file_descr -> bytes -> int -> int -> unit (* * Copy an entire file. *) val copy_file : string -> string -> int -> unit (* * Make all the directories in a path. *) val mkdirhier : string -> unit (* * Home directory of the current user. *) val home_dir : string (* * C interface. *) val int_of_fd : Unix.file_descr -> int (* * Lock utilities. *) val lockf : Unix.file_descr -> Unix.lock_command -> int -> unit val getlk : Unix.file_descr -> Unix.lock_command -> int option (* * File truncation. *) val ftruncate : Unix.file_descr -> unit (* * Get a value from the registry. * raises Not_found if the entry is not found or you are not using Win32. *) type registry_hkey = HKEY_CLASSES_ROOT | HKEY_CURRENT_CONFIG | HKEY_CURRENT_USER | HKEY_LOCAL_MACHINE | HKEY_USERS val registry_find : registry_hkey -> string -> string -> string (* * Open a file. * This is mainly for debugging. *) val openfile : string -> Unix.open_flag list -> Unix.file_perm -> Unix.file_descr (* * Simple file locking. *) type flock_command = LOCK_UN | LOCK_SH | LOCK_EX | LOCK_TSH | LOCK_TEX val flock : Unix.file_descr -> flock_command -> unit (* * Scan the password database for entries. *) val getpwents : unit -> Unix.passwd_entry list val finally : 'a -> ('a -> 'b) -> ('a -> 'c) -> 'b (** TODO: flags need to be documented *) val with_file_fmt : string -> (Format.formatter -> 'a) -> 'a (** TODO: using [Sys.readdir] instead *) val list_directory : string -> string list val try_unlink_file : string -> unit val moncontrol : bool -> unit (* control gprof activity *) omake-0.10.3/src/libmojave/lm_hash_code.mli0000644000175000017500000000227513177364666017213 0ustar gerdgerd(************************************************************************ * Better-than-usual hashes. *) module HashCode : sig type t val create : unit -> t val add_bits : t -> int -> unit (* Adds the last 11 bits *) val add_int : t -> int -> unit val add_nativeint : t -> Nativeint.t -> unit val add_int32 : t -> Int32.t -> unit val add_int64 : t -> Int64.t -> unit val add_float : t -> float -> unit val add_string : t -> string -> unit val code : t -> int end module HashDigest : sig type t val create : unit -> t val add_bits : t -> int -> unit (* Adds the last 11 bits *) val add_int : t -> int -> unit val add_nativeint : t -> Nativeint.t -> unit val add_int32 : t -> Int32.t -> unit val add_int64 : t -> Int64.t -> unit val add_float : t -> float -> unit val add_string : t -> string -> unit val add_char : t -> char -> unit val add_bool : t -> bool -> unit val add_substring : t -> string -> int -> int -> unit val digest : t -> string end val hash_combine : int -> int -> int val hash_int_list : int -> int list -> int val hash_list : ('a -> int) -> 'a list -> int omake-0.10.3/src/libmojave/lm_list_util.mli0000644000175000017500000001500313177364666017277 0ustar gerdgerd (* * Array-style operations. *) val sub : 'a list -> int -> int -> 'a list (* * Iterate over two lists, but stop at the * end of the shorter one. *) val short_iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit (* * Iteration over three lists. *) val iter3 : ('a -> 'b -> 'c -> unit) -> 'a list -> 'b list -> 'c list -> unit (* * Generalize fold_left over three lists. *) val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a (* * Reverse iteration *) val rev_iter : ('a -> 'b) -> 'a list -> unit val rev_iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit (* * Mapping functions. *) val flat_map : ('a -> 'b list) -> 'a list -> 'b list val fail_map : ('a -> 'b) -> 'a list -> 'b list val some_map : ('a -> 'b option) -> 'a list -> 'b list val some_map_safe : ('a -> 'a option) -> 'a list -> 'a list val fold_left : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list (* * Find the element that satisfies a predicate *) val find : ('a -> bool) -> 'a list -> 'a (* Now find its index *) val find_item : ('a -> bool) -> 'a list -> int (* By equality *) val find_index : 'a -> 'a list -> int val find_rindex : 'a -> 'a list -> int (* By pointer-equality *) val find_indexq : 'a -> 'a list -> int (* Use a provided equality *) val find_index_eq : ('a -> 'a -> bool) -> 'a -> 'a list -> int (* * Split the first elements from the last. * raises Failure if the list is empty. *) val split_list : int -> 'a list -> 'a list * 'a list val split_last : 'a list -> 'a list * 'a val last : 'a list -> 'a (* * Split the list into two parts. * raises Invalid_argument if the list is empty. *) val split : int -> 'a list -> 'a list * 'a list (* * Split up into smaller lists of size no more than n. *) val splitup : int -> 'a list -> 'a list list (* * Return the first n elements of the list. *) val firstn : int -> 'a list -> 'a list (* * Remove the first n elements of the list. *) val nth_tl : int -> 'a list -> 'a list (* * Subtract two lists as if they were sets. *) val subtract_list : 'a list -> 'a list -> 'a list val map2to1 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val fold_filter : ('a -> 'b -> 'a * bool) -> 'a -> 'b list -> 'a * 'b list (* * fold_map *) val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list val fold_map2to1 : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b list -> 'c list -> 'a * 'd list val fold_map1to2 : ('a -> 'b -> 'a * 'c * 'd) -> 'a -> 'b list -> 'a * 'c list * 'd list (* * Do map and try preserving sharing *) val smap : ('a -> 'a) -> 'a list -> 'a list (* * check lengths equal *) val length_eq : 'a list -> 'b list -> bool (* * Functional replacement. *) val replacef_nth : int -> ('a -> 'a) -> 'a list -> 'a list val replacef_arg_nth : int -> ('a -> 'a * 'b) -> 'a list -> 'a list * 'b val replace_nth : int -> 'a -> 'a list -> 'a list val replaceq : 'a -> 'a -> 'a list -> 'a list val replace_first : ('a -> bool) -> 'a -> 'a list -> 'a list val replace_all : ('a -> bool) -> 'a -> 'a list -> 'a list (* * Removing elements. *) val remove : 'a -> 'a list -> 'a list (* tryremove does not raise any exception when the element is not in the list *) val tryremove : 'a -> 'a list -> 'a list val removeq : 'a -> 'a list -> 'a list val remove_elements : bool list -> 'a list -> 'a list val remove_suffix : 'a list -> 'a list -> 'a list val insert_nth : int -> 'a -> 'a list -> 'a list val remove_nth : int -> 'a list -> 'a list (* Filter items out of a list *) val filter : ('a -> bool) -> 'a list -> 'a list (* * Set operations. *) val addq : 'a -> 'a list -> 'a list val intersect : 'a list -> 'a list -> 'a list val intersectq : 'a list -> 'a list -> 'a list val intersects : 'a list -> 'a list -> bool val subtract : 'a list -> 'a list -> 'a list val subtractq : 'a list -> 'a list -> 'a list val subtract_multiset : 'a list -> 'a list -> 'a list val union : 'a list -> 'a list -> 'a list val unionq : 'a list -> 'a list -> 'a list val subset : 'a list -> 'a list -> bool (* Lexicographic comparison of two lists *) val compare_lists : ('a -> 'b -> int) -> 'a list -> 'b list -> int (* Elements must by physically equal *) val compare_eq : 'a list -> 'a list -> bool (* Elements must be equal, but lists may be different lengths *) val compare_cmp : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (* * These functions are just like the List functions * but they raise Failure, not Invalid_argument. *) val nth : 'a list -> int -> 'a val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit (* Returns false if the list lengths mismatch *) val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (* Ignores the tail of the longer list *) val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (* * Association lists. *) (* zip_list a b c zips b and c and puts the result in front of a in reverce order *) val zip_list : ('a * 'b) list -> 'a list -> 'b list -> ('a * 'b) list val zip : 'a list -> 'b list -> ('a * 'b) list val fst_split : ('a * 'b) list -> 'a list val assoc_index : ('a * 'b) list -> 'a -> int val assoc_replace : ('a * 'b) list -> 'a -> 'b -> ('a * 'b) list val add_assoc : 'a * 'b -> ('a * 'b) list -> ('a * 'b) list val assoc_in_dom : ('b -> 'a -> bool) -> 'b -> ('a * 'c) list -> bool val assoc_in_range : ('b -> 'c -> bool) -> 'b -> ('a * 'c) list -> bool (* * assoc_append_replace_snd l1 b l2 replaces the second element of all pairs in l2 with b * and appends l1 at the end of the result *) val assoc_append_replace_snd : ('a * 'b) list -> 'b -> ('a * 'c) list -> ('a * 'b) list (* * Apply a function to the value in * an association list. *) val apply_assoc : 'a -> ('a * 'b) list -> ('b -> 'b) -> ('a * 'b) list (* * Association list with an equality. *) val assoc_eq : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b (* * if either of the assoc list sides has duplicate entries, only the first entry is used * and the duplicate entry forces all second component matches to return false * * i.e. check_assoc v1 v2 [1,2; 3,2; 3,4] = (v1<>3) && (v2<>4) && check_assoc v1 v2 [1,2] * * try_check_assoc is the same as check_assoc, but raises an exception if an entry is not found *) val check_assoc : 'a -> 'a -> ('a * 'a) list -> bool val try_check_assoc : 'a -> 'b -> ('a * 'b) list -> bool (* if left side has duplicate entries, only the first entry is used *) val try_assoc: 'a -> ('a * 'a) list -> 'a omake-0.10.3/src/ir/0000755000175000017500000000000013177364666012537 5ustar gerdgerdomake-0.10.3/src/ir/OMakefile0000644000175000017500000000121313177364665014312 0ustar gerdgerdOCAMLINCLUDES[] += ../libmojave ../front ../exec ../magic ../ast FILES[] = omake_options omake_symbol omake_state omake_node_type omake_node_sig omake_node omake_install omake_ir omake_var omake_ir_util omake_ir_print omake_ir_free_vars omake_lexer omake_parser omake_value_type omake_command_type omake_value_util omake_value_print omake_pos omake_shell_type omake_command omake_cache_type omake_cache MakeOCamlLibrary(ir, $(FILES)) clean: $(CLEAN) # # Generate the Makefile # MakeOCamlDepend($(FILES), magic.cma) MakeMakefile() omake-0.10.3/src/ir/omake_command_type.ml0000644000175000017500000001114113177364665016721 0ustar gerdgerd(* * Individual command arguments have three forms: * - value lists * - arg_string lists * - string * * The arg_string is like a string, but various parts of it are quoted. *) type arg_string = | ArgString of string | ArgData of string type arg = arg_string list type command_digest = Digest.t option (* * A command line is a string, together with come flags. *) type command_flag = | QuietFlag | AllowFailureFlag | AllowOutputFlag (* * The command line has some flags, * and a string to be executed internally * or passed to the shell. *) type ('exp, 'argv, 'value) poly_command_inst = | CommandEval of 'exp list | CommandPipe of 'argv | CommandValues of 'value list type ('venv, 'exp, 'argv, 'value) poly_command_line = { command_loc : Lm_location.t; command_dir : Omake_node.Dir.t; command_target : Omake_node.Node.t; command_flags : command_flag list; command_venv : 'venv; command_inst : ('exp, 'argv, 'value) poly_command_inst } let simple_string_of_arg arg = match arg with | [ArgString s] | [ArgData s] -> s | _ -> let buf = Buffer.create 32 in List.iter (fun arg -> let s = match arg with | ArgString s -> s | ArgData s -> s in Buffer.add_string buf s) arg; Buffer.contents buf let glob_string_of_arg options arg = let buf = Buffer.create 32 in List.iter (fun arg -> match arg with ArgString s -> Buffer.add_string buf s | ArgData s -> Lm_glob.glob_add_escaped options buf s) arg; Buffer.contents buf let is_glob_arg options arg = List.exists (fun arg -> match arg with | ArgString s -> Lm_glob.is_glob_string options s | ArgData _ -> false) arg let is_quoted_arg arg = List.exists (fun v -> match v with ArgString _ -> false | ArgData _ -> true) arg let pp_arg_data_string = let special1 = "\" \t<>&;()*~{}[]?!|" in (* Can be protected both by '...c...' and \c *) let special2 = "\\\n\r'" in (* Must be protected by \c *) let special_all = special1 ^ special2 in let rec pp_w_escapes buf special s = if Lm_string_util.contains_any s special then begin let i = Lm_string_util.index_set s special in Lm_printf.pp_print_string buf (String.sub s 0 i); Lm_printf.pp_print_char buf '\\'; Lm_printf.pp_print_char buf (**) (match s.[i] with '\n' -> 'n' | '\r' -> 'r' | '\t' -> 't' | c -> c); let i = i + 1 in pp_w_escapes buf special (String.sub s i (String.length s - i)) end else Lm_printf.pp_print_string buf s in let pp_w_quotes buf s = if Lm_string_util.contains_any s special1 then if String.length s > 2 then begin Lm_printf.pp_print_char buf '\''; pp_w_escapes buf special2 s; Lm_printf.pp_print_char buf '\'' end else pp_w_escapes buf special_all s else pp_w_escapes buf special2 s in pp_w_quotes let pp_print_arg = let pp_print_arg_elem buf = function ArgString s -> Lm_printf.pp_print_string buf s | ArgData s -> pp_arg_data_string buf s in (fun buf arg -> List.iter (pp_print_arg_elem buf) arg) let pp_print_verbose_arg buf arg = List.iter (fun arg -> match arg with ArgString s -> Lm_printf.pp_print_string buf s | ArgData s -> Format.fprintf buf "'%s'" s) arg let pp_print_command_flag buf flag = let c = match flag with QuietFlag -> '@' | AllowFailureFlag -> '-' | AllowOutputFlag -> '*' in Lm_printf.pp_print_char buf c let pp_print_command_flags buf flags = List.iter (pp_print_command_flag buf) flags module type PrintArgvSig = sig type argv val pp_print_argv : argv Lm_printf.t end;; module MakePrintCommand (PrintArgv : PrintArgvSig) = struct open PrintArgv let pp_print_command_inst buf inst = match inst with CommandPipe argv -> pp_print_argv buf argv | CommandEval exp -> Omake_ir_print.pp_print_exp_list_simple buf exp | CommandValues values -> Format.fprintf buf "" (List.length values) let pp_print_command_line buf line = pp_print_command_inst buf line.command_inst let pp_print_command_lines buf lines = List.iter (fun line -> Format.fprintf buf "@ %a" pp_print_command_line line) lines end;; omake-0.10.3/src/ir/omake_ir_free_vars.ml0000644000175000017500000001402313177364665016712 0ustar gerdgerd(* * Compute the free variables of an expression. * NOTE: this is a little sloppy. * 1. The language is dynamically scoped; * we don't catch variables not mentioned statically * 2. We take the presence of a definition anywhere * as an indication that the variable is not free. *) (* * Tables of free variables. *) type free_vars = Omake_ir_util.VarInfoSet.t let free_vars_empty = Omake_ir_util.VarInfoSet.empty (* * Free variable operations. *) let free_vars_add = Omake_ir_util.VarInfoSet.add let free_vars_remove = Omake_ir_util.VarInfoSet.remove let free_vars_remove_param_list fv params = List.fold_left Omake_ir_util.VarInfoSet.remove fv params let free_vars_remove_opt_param_list fv keywords = List.fold_left (fun fv (_, v, _) -> Omake_ir_util.VarInfoSet.remove fv v) fv keywords (* * Union of two free variable sets. *) let free_vars_union fv1 fv2 = Omake_ir_util.VarInfoSet.fold Omake_ir_util.VarInfoSet.add fv1 fv2 (* * Free vars of the export. *) let free_vars_export_info fv info = match info with Omake_ir.ExportNone | Omake_ir.ExportAll -> fv | Omake_ir.ExportList items -> List.fold_left (fun fv item -> match item with Omake_ir.ExportRules | ExportPhonies -> fv | ExportVar v -> Omake_ir_util.VarInfoSet.add fv v) fv items (* * Free vars in optional args. *) let rec free_vars_opt_params fv opt_params = match opt_params with (_, _, Some s) :: opt_params -> free_vars_opt_params (free_vars_string_exp fv s) opt_params | (_, _, None) :: opt_params -> free_vars_opt_params fv opt_params | [] -> fv (* * Calculate free vars. * NOTE: this only calculates the static free variables. * Since the language is dynamically scoped, this will miss * the dynamic free variables. *) and free_vars_string_exp fv s = match s with |Omake_ir.NoneString _ | IntString _ | FloatString _ | WhiteString _ | ConstString _ | ThisString _ | KeyApplyString _ | VarString _ -> fv | FunString (_, opt_params, vars, s, export) -> let fv_body = free_vars_export_info free_vars_empty export in let fv_body = free_vars_exp_list fv_body s in let fv_body = free_vars_remove_param_list fv_body vars in let fv_body = free_vars_remove_opt_param_list fv_body opt_params in let fv = free_vars_union fv fv_body in free_vars_opt_params fv opt_params | ApplyString (_, v, args, kargs) | MethodApplyString (_, v, _, args, kargs) -> let fv = free_vars_string_exp_list fv args in let fv = free_vars_keyword_exp_list fv kargs in free_vars_add fv v | SuperApplyString (_, _, _, args, kargs) -> let fv = free_vars_string_exp_list fv args in let fv = free_vars_keyword_exp_list fv kargs in fv | SequenceString (_, sl) | ArrayString (_, sl) | QuoteString (_, sl) | QuoteStringString (_, _, sl) -> free_vars_string_exp_list fv sl | ArrayOfString (_, s) | LazyString (_, s) -> free_vars_string_exp fv s | ObjectString (_, e, export) | BodyString (_, e, export) | ExpString (_, e, export) -> free_vars_exp_list (free_vars_export_info fv export) e | CasesString (_loc, cases) -> free_vars_cases fv cases | LetVarString (_, v, e1, _e2) -> let fv = free_vars_string_exp fv e1 in let fv = free_vars_remove fv v in free_vars_string_exp fv e1 and free_vars_string_exp_list fv sl = match sl with s :: sl -> free_vars_string_exp_list (free_vars_string_exp fv s) sl | [] -> fv and free_vars_keyword_exp_list fv sl = match sl with (_, s) :: sl -> free_vars_keyword_exp_list (free_vars_string_exp fv s) sl | [] -> fv and free_vars_cases fv cases = match cases with (_, s, e, export) :: cases -> free_vars_cases (free_vars_string_exp (free_vars_exp_list (free_vars_export_info fv export) e) s) cases | [] -> fv and free_vars_exp_list fv el = match el with e :: el -> free_vars_exp (free_vars_exp_list fv el) e | [] -> fv and free_vars_exp fv e = match e with LetVarExp (_, v, _, _, s) -> let fv = free_vars_remove fv v in free_vars_string_exp fv s | LetFunExp (_, v, _, _, opt_params, vars, el, export) -> let fv_body = free_vars_export_info free_vars_empty export in let fv_body = free_vars_exp_list fv_body el in let fv_body = free_vars_remove_param_list fv_body vars in let fv_body = free_vars_remove_opt_param_list fv_body opt_params in let fv = free_vars_union fv fv_body in let fv = free_vars_remove fv v in free_vars_opt_params fv opt_params | LetObjectExp (_, v, _, s, el, export) -> let fv = free_vars_export_info fv export in let fv = free_vars_exp_list fv el in let fv = free_vars_remove fv v in let fv = free_vars_string_exp fv s in fv | IfExp (_, cases) -> free_vars_if_cases fv cases | SequenceExp (_, el) -> free_vars_exp_list fv el | SectionExp (_, s, el, export) -> free_vars_string_exp (free_vars_exp_list (free_vars_export_info fv export) el) s | StaticExp (_, _, _, el) -> free_vars_exp_list fv el | IncludeExp (_, s, sl) -> free_vars_string_exp (free_vars_string_exp_list fv sl) s | ApplyExp (_, v, args, kargs) | MethodApplyExp (_, v, _, args, kargs) -> free_vars_keyword_exp_list (free_vars_string_exp_list (free_vars_add fv v) args) kargs | SuperApplyExp (_, _, _, args, kargs) -> free_vars_keyword_exp_list (free_vars_string_exp_list fv args) kargs | ReturnBodyExp (_, el, _) -> free_vars_exp_list fv el | LetKeyExp (_, _, _, s) | LetThisExp (_, s) | ShellExp (_, s) | StringExp (_, s) | ReturnExp (_, s, _) -> free_vars_string_exp fv s | OpenExp _ | KeyExp _ | ReturnObjectExp _ | ReturnSaveExp _ -> fv and free_vars_if_cases fv cases = match cases with | (s, e, export) :: cases -> free_vars_if_cases (free_vars_string_exp (free_vars_exp_list (free_vars_export_info fv export) e) s) cases | [] -> fv (* * Wrapper. *) let free_vars_exp e = free_vars_exp free_vars_empty e let free_vars_exp_list el = free_vars_exp_list free_vars_empty el let free_vars_set fv = fv omake-0.10.3/src/ir/omake_value_print.ml0000644000175000017500000003155413177364665016604 0ustar gerdgerd (************************************************************************ * Simple printing. *) (* let pp_print_string_list buf sl = *) (* List.iter (fun s -> Format.fprintf buf "@ %s" s) sl *) (* let pp_print_node_list buf l = *) (* List.iter (fun s -> Format.fprintf buf "@ %a" Omake_node.pp_print_node s) l *) (* let pp_print_node_set buf set = *) (* Omake_node.NodeSet.iter (fun s -> Format.fprintf buf "@ %a" Omake_node.pp_print_node s) set *) let pp_print_wild_list buf wl = List.iter (fun w -> Format.fprintf buf "@ %a" Lm_wild.pp_print_wild_in w) wl let pp_print_source buf (_, source) = match source with | Omake_value_type.SourceWild wild -> Lm_wild.pp_print_wild_out buf wild | SourceNode node -> Omake_node.pp_print_node buf node let pp_print_source_list buf sources = List.iter (fun source -> Format.fprintf buf "@ %a" pp_print_source source) sources let pp_print_target buf target = match target with | Omake_value_type.TargetNode node -> Omake_node.pp_print_node buf node | TargetString s -> Lm_printf.pp_print_string buf s (* let pp_print_required buf b = *) (* if b then *) (* Lm_printf.pp_print_char buf '~' *) (* else *) (* Lm_printf.pp_print_char buf '?' *) (************************************************************************ * Path printing. *) let rec pp_print_path buf = function | Omake_value_type.PathVar info -> Omake_ir_print.pp_print_var_info buf info | PathField (path, _obj, v) -> Format.fprintf buf "%a.%a" Lm_symbol.pp_print_symbol v pp_print_path path (************************************************************************ * Arity approximation. *) (* * XXX: TODO: currently keyword args are ignored, we should probably include * them, and also return an ArityRange when some keyword arguments have a default * value defined. See also Bugzilla bug 731. *) let fun_arity _keywords params = Omake_ir.ArityExact (List.length params) let curry_fun_arity curry_args _keywords params _curry_kargs = Omake_ir.ArityExact ((List.length params) - (List.length curry_args)) (************************************************************************ * Value printing. *) let rec pp_print_value buf v = match v with Omake_value_type.ValNone -> Lm_printf.pp_print_string buf "" | ValInt i -> Format.fprintf buf "%d : Int" i | ValFloat x -> Format.fprintf buf "%g : Float" x | ValData s -> Format.fprintf buf "@[ : String@]" (String.escaped s) | ValQuote vl -> Format.fprintf buf "@[@ : String@]" pp_print_value_list vl | ValWhite s -> Format.fprintf buf "'%s' : White" (String.escaped s) | ValString s -> Format.fprintf buf "\"%s\" : Sequence" (String.escaped s) | ValQuoteString (c, vl) -> Format.fprintf buf "@[@ : String@]" c pp_print_value_list vl c | ValSequence [v] -> pp_print_value buf v | ValSequence vl -> Format.fprintf buf "@[@ : Sequence@]" pp_print_value_list vl | ValArray vl -> Format.fprintf buf "@[@ : Array@]" pp_print_value_list vl | ValMaybeApply (_, v) -> Format.fprintf buf "@[ifdefined(%a)@]" (**) Omake_ir_print.pp_print_var_info v | ValFun (_, keywords, params, _, _) -> Format.fprintf buf "" Omake_ir_print.pp_print_arity (fun_arity keywords params) | ValFunCurry (_, curry_args, keywords, params, _, _, curry_kargs) -> Format.fprintf buf "" Omake_ir_print.pp_print_arity (curry_fun_arity curry_args keywords params curry_kargs) | ValPrim (_, special, _, name) | ValPrimCurry (_, special, name, _, _) -> if special then Format.fprintf buf "" Lm_symbol.pp_print_symbol name else Format.fprintf buf "" Lm_symbol.pp_print_symbol name | ValRules rules -> Format.fprintf buf "<@[rules:"; List.iter (fun erule -> Format.fprintf buf "@ %a" Omake_node.pp_print_node erule) rules; Format.fprintf buf "@]>" | ValDir dir -> Format.fprintf buf "%a : Dir" Omake_node.pp_print_dir dir | ValNode node -> Format.fprintf buf "%a : File" Omake_node.pp_print_node node | ValStringExp (_, e) -> Format.fprintf buf "@[%a : Exp@]" Omake_ir_print.pp_print_string_exp e | ValBody (_, [], [], el, export) -> Format.fprintf buf "@[%a%a@ : Body@]" Omake_ir_print.pp_print_exp_list el Omake_ir_print.pp_print_export_info export | ValBody (_, keywords, params, el, export) -> Format.fprintf buf "@[%a => %a%a@ : Body@]" Omake_ir_print.pp_print_arity (fun_arity keywords params) Omake_ir_print.pp_print_exp_list el Omake_ir_print.pp_print_export_info export | ValObject env -> pp_print_env buf env | ValMap map -> Format.fprintf buf "@[map"; Omake_value_util.ValueTable.iter (fun v e -> Format.fprintf buf "@ %a@ = %a" pp_print_value v pp_print_value e) map; Format.fprintf buf "@]" | ValChannel (InChannel, _) -> Format.fprintf buf " : InChannel" | ValChannel (OutChannel, _) -> Format.fprintf buf " : OutChannel" | ValChannel (InOutChannel, _) -> Format.fprintf buf " : InOutChannel" | ValClass c -> Format.fprintf buf "@[class"; Lm_symbol.SymbolTable.iter (fun v _ -> Format.fprintf buf "@ %a" Lm_symbol.pp_print_symbol v) c; Format.fprintf buf "@]" | ValCases cases -> Format.fprintf buf "@[cases"; List.iter (fun (v, e1, e2, export) -> Format.fprintf buf "@[%a %a:@ %a%a@]" (**) Lm_symbol.pp_print_symbol v pp_print_value e1 Omake_ir_print.pp_print_exp_list e2 Omake_ir_print.pp_print_export_info export) cases; Format.fprintf buf "@]" | ValVar (_, v) -> Format.fprintf buf "`%a" Omake_ir_print.pp_print_var_info v | ValOther (ValLexer _) -> Format.fprintf buf " : Lexer" | ValOther (ValParser _) -> Format.fprintf buf " : Parser" | ValOther (ValLocation loc) -> Format.fprintf buf " : Location" Lm_location.pp_print_location loc | ValOther (ValExitCode code) -> Format.fprintf buf " : Int" code | ValOther (ValEnv _) -> Format.fprintf buf "" | ValDelayed { contents = ValValue v } -> Format.fprintf buf "" pp_print_value v | ValDelayed { contents = ValStaticApply (key, v) } -> Format.fprintf buf "" pp_print_value key Lm_symbol.pp_print_symbol v and pp_print_value_list buf vl = List.iter (fun v -> Format.fprintf buf "@ %a" pp_print_value v) vl (* and pp_print_normal_args buf first args = *) (* match args with *) (* arg :: args -> *) (* if not first then *) (* Format.fprintf buf ",@ "; *) (* pp_print_value buf arg; *) (* pp_print_normal_args buf false args *) (* | [] -> *) (* first *) (* and pp_print_keyword_args buf first kargs = *) (* match kargs with *) (* (v, arg) :: kargs -> *) (* if not first then *) (* Format.fprintf buf ",@ "; *) (* Format.fprintf buf "@[%a =@ %a@]" Lm_symbol.pp_print_symbol v pp_print_value arg; *) (* pp_print_keyword_args buf false kargs *) (* | [] -> *) (* () *) (* and pp_print_value_args buf (args, kargs) = *) (* pp_print_keyword_args buf (pp_print_normal_args buf true args) kargs *) and pp_print_env buf env = let tags = Omake_value_util.venv_get_class env in let env = Lm_symbol.SymbolTable.remove env Omake_value_util.class_sym in Format.fprintf buf "@[@[class"; Lm_symbol.SymbolTable.iter (fun v _ -> Format.fprintf buf "@ %a" Lm_symbol.pp_print_symbol v) tags; Format.fprintf buf "@]"; Lm_symbol.SymbolTable.iter (fun v e -> Format.fprintf buf "@ %a = %a" Lm_symbol.pp_print_symbol v pp_print_value e) env; Format.fprintf buf "@]" (************************************************************************ * Simplified printing. *) let rec pp_print_simple_value buf v = match v with Omake_value_type.ValNone -> Lm_printf.pp_print_string buf "" | ValInt i -> Lm_printf.pp_print_int buf i | ValFloat x -> Lm_printf.pp_print_float buf x | ValData s -> Omake_command_type.pp_print_arg buf [ArgData s] | ValWhite s | ValString s -> Omake_command_type.pp_print_arg buf [ArgString s] | ValQuote vl -> Format.fprintf buf "\"%a\"" pp_print_simple_value_list vl | ValQuoteString (c, vl) -> Format.fprintf buf "%c%a%c" c pp_print_simple_value_list vl c | ValSequence vl -> pp_print_simple_value_list buf vl | ValArray vl -> pp_print_simple_arg_list buf vl | ValMaybeApply (_, v) -> Format.fprintf buf "$?(%a)" (**) Omake_ir_print.pp_print_var_info v | ValFun _ -> Lm_printf.pp_print_string buf "" | ValFunCurry _ -> Lm_printf.pp_print_string buf "" | ValPrim _ | ValPrimCurry _ -> Lm_printf.pp_print_string buf "" | ValRules _ -> Lm_printf.pp_print_string buf "" | ValDir dir -> Omake_node.pp_print_dir buf dir | ValNode node -> Omake_node.pp_print_node buf node | ValStringExp _ -> Lm_printf.pp_print_string buf "" | ValBody _ -> Lm_printf.pp_print_string buf "" | ValObject _ -> Lm_printf.pp_print_string buf "" | ValMap _ -> Lm_printf.pp_print_string buf "" | ValChannel _ -> Lm_printf.pp_print_string buf "" | ValClass _ -> Lm_printf.pp_print_string buf "" | ValCases _ -> Lm_printf.pp_print_string buf "" | ValVar (_, v) -> Format.fprintf buf "`%a" Omake_ir_print.pp_print_var_info v | ValOther (ValLexer _) -> Lm_printf.pp_print_string buf "" | ValOther (ValParser _) -> Lm_printf.pp_print_string buf "" | ValOther (ValLocation _) -> Lm_printf.pp_print_string buf "" | ValOther (ValExitCode i) -> Lm_printf.pp_print_int buf i | ValOther (ValEnv _) -> Lm_printf.pp_print_string buf "" | ValDelayed { contents = ValValue v } -> pp_print_simple_value buf v | ValDelayed { contents = ValStaticApply _ } -> Lm_printf.pp_print_string buf "" and pp_print_simple_value_list buf vl = List.iter (pp_print_simple_value buf) vl and pp_print_simple_arg_list buf vl = match vl with | [] -> () | [v] -> pp_print_simple_value buf v | v :: vl -> pp_print_simple_value buf v; Lm_printf.pp_print_char buf ' '; pp_print_simple_arg_list buf vl let rec pp_print_item buf (x : Omake_value_type.item ) = match x with | AstExp e -> Omake_ast_print.pp_print_exp buf e | IrExp e -> Omake_ir_print.pp_print_exp buf e | Location _ -> () | Symbol v -> Lm_symbol.pp_print_symbol buf v | String s -> Lm_printf.pp_print_string buf s | Value v -> pp_print_value buf v | Error e -> pp_print_exn buf e and pp_print_exn buf (x : Omake_value_type.omake_error )= match x with | SyntaxError s -> Format.fprintf buf "syntax error: %s" s | StringAstError (s, e) -> Format.fprintf buf "@[%s:@ %a@]" s Omake_ast_print.pp_print_simple_exp e | StringError s -> Lm_printf.pp_print_string buf s | StringIntError (s, i) -> Format.fprintf buf "%s: %d" s i | StringStringError (s1, s2) -> Format.fprintf buf "%s: %s" s1 s2 | StringVarError (s, v) -> Format.fprintf buf "%s: %a" s Lm_symbol.pp_print_symbol v | StringMethodError (s, v) -> Format.fprintf buf "%s: %a" s Lm_symbol.pp_print_method_name v | StringDirError (s, n)-> Format.fprintf buf "%s: %a" s Omake_node.pp_print_dir n | StringNodeError (s, n)-> Format.fprintf buf "%s: %a" s Omake_node.pp_print_node n | StringValueError (s, v) -> Format.fprintf buf "@[%s:@ %a@]" s pp_print_value v | StringTargetError (s, t) -> Format.fprintf buf "%s: %a" s pp_print_target t | LazyError printer -> printer buf | UnboundVar v -> Format.fprintf buf "unbound variable: %a" Lm_symbol.pp_print_symbol v | UnboundVarInfo v -> Format.fprintf buf "unbound variable: %a" Omake_ir_print.pp_print_var_info v | UnboundKey v -> Format.fprintf buf "unbound key: %s" v | UnboundValue v -> Format.fprintf buf "unbound value: %a" pp_print_value v | UnboundFun v -> Format.fprintf buf "unbound function: %a" Lm_symbol.pp_print_symbol v | UnboundMethod vl -> Format.fprintf buf "unbound method: %a" Lm_symbol.pp_print_method_name vl | UnboundFieldVar (obj, v) -> Format.fprintf buf "@[unbound method '%a', object classes:@ @[" Lm_symbol.pp_print_symbol v; Lm_symbol.SymbolTable.iter (fun v _ -> Format.fprintf buf "@ %a" Lm_symbol.pp_print_symbol v) (Omake_value_util.venv_get_class obj); Format.fprintf buf "@]@]" | ArityMismatch (len1, len2) -> Format.fprintf buf "arity mismatch: expected %a args, got %d" Omake_ir_print.pp_print_arity len1 len2 | NotImplemented s -> Format.fprintf buf "not implemented: %s" s | NullCommand -> Lm_printf.pp_print_string buf "invalid null command" omake-0.10.3/src/ir/omake_shell_type.ml0000644000175000017500000001654013177364665016422 0ustar gerdgerd(* * Shell expressions. *) (* * A shell command. *) type 'arg cmd_exe = CmdArg of 'arg | CmdNode of Omake_node.Node.t type simple_exe = ExeNode of Omake_node.Node.t | ExeString of string | ExeQuote of string type 'arg redirect = | RedirectNode of Omake_node.Node.t | RedirectArg of 'arg | RedirectNone type ('exe, 'arg_command, 'arg_other) poly_cmd = { cmd_loc : Lm_location.t; cmd_env : (Lm_symbol.t * 'arg_other) list; cmd_exe : 'exe; cmd_argv : 'arg_command list; cmd_stdin : 'arg_other redirect; cmd_stdout : 'arg_other redirect; cmd_stderr : bool; cmd_append : bool } (* * An internal command. * * 'apply with be: venv -> Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> string list -> int * value *) type ('arg_apply, 'arg_other, 'apply) poly_apply = { apply_loc : Lm_location.t; apply_env : (Lm_symbol.t * 'arg_other) list; apply_name : Lm_symbol.t; apply_fun : 'apply; apply_args : 'arg_apply list; apply_stdin : 'arg_other redirect; apply_stdout : 'arg_other redirect; apply_stderr : bool; apply_append : bool } (* * A pipe may have several cmds in sequence. *) type pipe_op = PipeAnd | PipeOr | PipeSequence (* * A pipe with redirection. *) type ('exe, 'arg_command, 'arg_apply, 'arg_other, 'apply) poly_group = { group_stdin : 'arg_other redirect; group_stdout : 'arg_other redirect; group_stderr : bool; group_append : bool; group_pipe : ('exe, 'arg_command, 'arg_apply, 'arg_other, 'apply) poly_pipe } and ('exe, 'arg_command, 'arg_apply, 'arg_other, 'apply) poly_pipe = PipeApply of Lm_location.t * ('arg_apply, 'arg_other, 'apply) poly_apply | PipeCommand of Lm_location.t * ('exe, 'arg_command, 'arg_other) poly_cmd | PipeCond of Lm_location.t * pipe_op (**) * ('exe, 'arg_command, 'arg_apply, 'arg_other, 'apply) poly_pipe * ('exe, 'arg_command, 'arg_apply, 'arg_other, 'apply) poly_pipe | PipeCompose of Lm_location.t * bool (**) * ('exe, 'arg_command, 'arg_apply, 'arg_other, 'apply) poly_pipe * ('exe, 'arg_command, 'arg_apply, 'arg_other, 'apply) poly_pipe | PipeGroup of Lm_location.t * ('exe, 'arg_command, 'arg_apply, 'arg_other, 'apply) poly_group | PipeBackground of Lm_location.t * ('exe, 'arg_command, 'arg_apply, 'arg_other, 'apply) poly_pipe (* * Signals. *) type signal = | SigAbrt | SigAlrm | SigFPE | SigHup | SigIll | SigInt | SigKill | SigPipe | SigQuit | SigSegv | SigTerm | SigUsr1 | SigUsr2 | SigChld | SigCont | SigStop | SigTstp | SigTtin | SigTtou | SigVTAlrm | SigProf | SigNum of int (* * Debug flag. *) let debug_shell = Lm_debug.create_debug (**) { debug_name = "shell"; debug_description = "print debugging information for the shell"; debug_value = false } (* * Operators. *) let pp_print_pipe_op buf op = let s = match op with | PipeAnd -> "&&" | PipeOr -> "||" | PipeSequence -> ";" in Lm_printf.pp_print_string buf s (* * Parameterized printing. *) module type PrintArgSig = sig type arg_command type arg_apply type arg_other type exe val pp_print_exe : exe Lm_printf.t val pp_print_arg_command : arg_command Lm_printf.t val pp_print_arg_apply : arg_apply Lm_printf.t val pp_print_arg_other : arg_other Lm_printf.t end;; module MakePrintPipe (PrintArg : PrintArgSig) = struct open PrintArg (* * Print redirects. *) let pp_print_stdin buf stdin = match stdin with RedirectNode node -> Format.fprintf buf " < %a" Omake_node.pp_print_node node | RedirectArg name -> Format.fprintf buf " < %a" pp_print_arg_other name | RedirectNone -> () let token_of_stdout stderr append = match stderr, append with true, true -> ">>&" | true, false -> ">&" | false, true -> ">>" | false, false -> ">" let pp_print_stdout buf (stdout, stderr, append) = match stdout with RedirectNode name -> let dir = token_of_stdout stderr append in Format.fprintf buf " %s %a" dir Omake_node.pp_print_node name | RedirectArg name -> let dir = token_of_stdout stderr append in Format.fprintf buf " %s %a" dir pp_print_arg_other name | RedirectNone -> () (* * Print the argument lists. *) let pp_print_args buf = function [] -> () | arg :: args -> pp_print_arg_apply buf arg; List.iter (fun arg -> Format.fprintf buf " %a" pp_print_arg_apply arg) args let pp_print_argv buf argv = List.iter (fun arg -> Format.fprintf buf " %a" pp_print_arg_command arg) argv (* * Print the environment. *) let pp_print_env buf env = List.iter (fun (v, arg) -> Format.fprintf buf "%a=%a " Lm_symbol.pp_print_symbol v pp_print_arg_other arg) env (* * An internal function/alias. *) let pp_print_apply buf apply = let { apply_env = env; apply_name = f; apply_args = args; apply_stdin = stdin; apply_stdout = stdout; apply_stderr = stderr; apply_append = append; _ } = apply in Format.fprintf buf "@[%aShell.%a(%a)%a%a@]" (**) pp_print_env env Lm_symbol.pp_print_symbol f pp_print_args args pp_print_stdin stdin pp_print_stdout (stdout, stderr, append) (* * Print a command. *) let pp_print_command buf command = let { cmd_exe = exe; cmd_env = env; cmd_argv = argv; cmd_stdin = stdin; cmd_stdout = stdout; cmd_stderr = stderr; cmd_append = append; _ } = command in Format.fprintf buf "@[%a%a%a%a%a@]" (**) pp_print_env env pp_print_exe exe pp_print_argv argv pp_print_stdin stdin pp_print_stdout (stdout, stderr, append) (* * Print a pipe. *) let rec pp_print_pipe buf pipe = match pipe with PipeApply (_, apply) -> pp_print_apply buf apply | PipeCommand (_, command) -> pp_print_command buf command | PipeCond (_, op, pipe1, pipe2) -> Format.fprintf buf "@[%a@ %a %a@]" (**) pp_print_pipe pipe1 pp_print_pipe_op op pp_print_pipe pipe2 | PipeCompose (_, divert_stderr, pipe1, pipe2) -> Format.fprintf buf "@[%a@ %s %a@]" (**) pp_print_pipe pipe1 (if divert_stderr then "|&" else "|") pp_print_pipe pipe2 | PipeGroup (_, group) -> pp_print_group buf group | PipeBackground (_, pipe) -> Format.fprintf buf "%a &" pp_print_pipe pipe and pp_print_group buf group = let { group_stdin = stdin; group_stdout = stdout; group_stderr = stderr; group_append = append; group_pipe = pipe } = group in Format.fprintf buf "@[(%a)%a%a@]" (**) pp_print_pipe pipe pp_print_stdin stdin pp_print_stdout (stdout, stderr, append) end omake-0.10.3/src/ir/omake_cache_type.ml0000644000175000017500000000155013177364665016351 0ustar gerdgerd(* Types used to represent commands and the cache. *) (* %%MAGICBEGIN%% *) (* * File digest is an option, in case the file does not exist. * The left string is a compactified version of Unix.stat. The right * half is the MD5 digest. *) type digest = (string * Digest.t) option (* * The memo result is used only for the scanner, * whice produces a table of dependencies. *) type 'a memo_result = MemoFailure of int | MemoSuccess of 'a type memo_deps = Omake_node.NodeSet.t Omake_node.NodeTable.t type memo_deps_result = memo_deps memo_result type memo_obj_result = Omake_value_type.obj memo_result (* * Status query. *) type memo_status = StatusSuccess | StatusFailure of int | StatusUnknown (* * A directory entry is a node or directory. *) type dir_entry = NodeEntry of Omake_node.Node.t | DirEntry of Omake_node.Dir.t (* %%MAGICEND%% *) omake-0.10.3/src/ir/omake_value_type.ml0000644000175000017500000001503113177364665016421 0ustar gerdgerd (* %%MAGICBEGIN%% *) (* * Various kinds of handles. *) type handle_env = Lm_handle_table.handle (* * I/O channels. *) type channel_mode = Lm_channel.mode = InChannel | OutChannel | InOutChannel type prim_channel = Lm_int_handle_table.handle (* * Possible values. * Someday we may want to include rules and functions. * For the function, the obj is the static scope. * * GS: * ValQuote This is just a concatenation of the inner stuff as string. * Unlike ValSequence this doesn't generate a list of words. * ValQuoteString Concatenates the inner stuff and puts the quote char * around it. Keeping that info seems reasonable because * you can auto-escape the inner data. * ValBody/ValFun These are now very similar - both can take parameters. * The difference is that a ValFun sets the static env * (i.e. private vars) to the scope of the time when the * function was defined. ValBody doesn't do this, and hence * the static env of the caller is used for the evaluation. *) type t = | ValNone | ValInt of int | ValFloat of float | ValSequence of t list | ValArray of t list | ValWhite of string | ValString of string | ValData of string | ValQuote of t list | ValQuoteString of char * t list | ValRules of Omake_node.Node.t list | ValNode of Omake_node.Node.t | ValDir of Omake_node.Dir.t | ValObject of obj | ValMap of map | ValChannel of channel_mode * prim_channel | ValClass of obj Lm_symbol.SymbolTable.t (* Raw expressions *) | ValStringExp of env * Omake_ir.string_exp | ValBody of env * keyword_param_value list * Omake_ir.param list * Omake_ir.exp list * Omake_ir.export | ValCases of (Omake_ir.var * t * Omake_ir.exp list * Omake_ir.export) list (* Functions *) | ValFun of env * keyword_param_value list * Omake_ir.param list * Omake_ir.exp list * Omake_ir.export | ValFunCurry of env * param_value list * keyword_param_value list * Omake_ir.param list * Omake_ir.exp list * Omake_ir.export * keyword_value list (* Closed values *) | ValPrim of Omake_ir.arity * bool * Omake_ir.apply_empty_strategy * prim_fun (* The args, kargs are kept in -reverse- order *) | ValPrimCurry of Omake_ir.arity * bool * prim_fun * t list * keyword_value list (* Implicit t dependencies *) | ValMaybeApply of Lm_location.t * Omake_ir.var_info (* Variables that are not applications *) | ValVar of Lm_location.t * Omake_ir.var_info (* Other values *) | ValOther of value_other (* Delayed values *) | ValDelayed of value_delayed ref (* * Put all the other stuff here, to keep the primary t type * smaller. *) and value_other = | ValLexer of Omake_lexer.Lexer.t | ValParser of Omake_parser.Parser.t | ValLocation of Lm_location.t | ValExitCode of int | ValEnv of handle_env * Omake_ir.export and value_delayed = | ValValue of t (* Value in a static block *) | ValStaticApply of t * Omake_ir.var (* * Arguments have an optional keyword. *) and param_value = Omake_ir.param * t and keyword_value = Omake_ir.var * t and keyword_param_value = Omake_ir.var * Omake_ir.param * t option (* * Primitives are option refs. * We do this so that we can marshal these values. * Just before marshaling, all the options are set to None. *) and prim_fun = Lm_symbol.t (* * An object is just an environment. *) and obj = t Lm_symbol.SymbolTable.t and env = t Lm_symbol.SymbolTable.t and map = (t, t) Lm_map.tree (* %%MAGICEND%% *) (************************************************************************ * Non-marshaled values. *) (* * A method path. *) type path = | PathVar of Omake_ir.var_info | PathField of path * obj * Omake_ir.var (* * Command lists are used for rule bodies. * They have their environment, a list of sources, * and the actual body. The body is polymorphic * for various kinds of commands. *) type command = | CommandSection of t * Omake_ir_free_vars.free_vars * Omake_ir.exp list (* Name of the section, its free variables, and the expression *) | CommandValue of Lm_location.t * env * Omake_ir.string_exp (* * Kinds of rules. *) type rule_multiple = | RuleSingle | RuleMultiple | RuleScannerSingle | RuleScannerMultiple type rule_kind = | RuleNormal | RuleScanner (* * A target t that represents a node in a rule. *) type target = | TargetNode of Omake_node.Node.t | TargetString of string (* * A source is either * 1. A wild string * 2. A node * 3. An optional source * 4. A squashed source *) type source_core = | SourceWild of Lm_wild.out_patt | SourceNode of Omake_node.Node.t type 'a source = Omake_node_sig.node_kind * 'a (************************************************************************ * Exceptions. *) type item = | Symbol of Lm_symbol.t | String of string | AstExp of Omake_ast.exp | IrExp of Omake_ir.exp | Location of Lm_location.t | Value of t | Error of omake_error and pos = item Lm_position.pos and omake_error = | SyntaxError of string | StringError of string | StringAstError of string * Omake_ast.exp | StringStringError of string * string | StringDirError of string * Omake_node.Dir.t | StringNodeError of string * Omake_node.Node.t | StringVarError of string * Omake_ir.var | StringIntError of string * int | StringMethodError of string * Omake_ir.var list | StringValueError of string * t | StringTargetError of string * target | LazyError of (Format.formatter -> unit) | UnboundVar of Omake_ir.var | UnboundVarInfo of Omake_ir.var_info | UnboundFun of Omake_ir.var | UnboundMethod of Omake_ir.var list | UnboundFieldVar of obj * Omake_ir.var | ArityMismatch of Omake_ir.arity * int | NotImplemented of string | UnboundKey of string | UnboundValue of t | NullCommand (* * Standard exceptions. *) exception OmakeException of pos * omake_error exception UncaughtException of pos * exn exception RaiseException of pos * obj exception ExitException of pos * int exception ExitParentException of pos * int exception Return of Lm_location.t * t * Omake_ir.return_id (* * Omake's internal version of the Invalid_argument *) exception OmakeFatal of string exception OmakeFatalErr of pos * omake_error omake-0.10.3/src/ir/omake_value_util.ml0000644000175000017500000000775213177364665016430 0ustar gerdgerdopen Omake_value_type (* * Position printer. *) module type PosSig = sig val loc_exp_pos : Lm_location.t -> pos val loc_pos : Lm_location.t -> pos -> pos val ast_exp_pos : Omake_ast.exp -> pos val ir_exp_pos : Omake_ir.exp -> pos val var_exp_pos : Omake_ir.var -> pos val string_exp_pos : string -> pos val value_exp_pos : t -> pos val string_pos : string -> pos -> pos val pos_pos : pos -> pos -> pos val int_pos : int -> pos -> pos val var_pos : Omake_ir.var -> pos -> pos val error_pos : omake_error -> pos -> pos val del_pos : (Format.formatter -> unit) -> Lm_location.t -> pos val del_exp_pos : (Format.formatter -> unit) -> pos -> pos (* Utilities *) val loc_of_pos : pos -> Lm_location.t val pp_print_pos : Format.formatter -> pos -> unit end (************************************************************************ * Basic values and functions. *) (* * Empty object. *) let empty_obj = Lm_symbol.SymbolTable.empty (* * Get the class identifiers from the object. *) let class_sym = Lm_symbol.add "$class" let venv_get_class obj = match Lm_symbol.SymbolTable.find obj class_sym with | ValClass table -> table | _ -> Lm_symbol.SymbolTable.empty | exception Not_found -> Lm_symbol.SymbolTable.empty (************************************************************************ * Value table. *) module ValueCompare = struct type t = Omake_value_type.t (* * Check for simple values. * Arrays cannot be nested. *) let check_simple pos v = match v with ValNone | ValInt _ | ValFloat _ | ValData _ | ValNode _ | ValDir _ | ValOther (ValLocation _) | ValOther (ValExitCode _) | ValVar _ -> () | _ -> raise (OmakeException (pos, StringValueError ("illegal Map key", v))) let check pos v = (match v with ValArray vl -> List.iter (check_simple pos) vl | _ -> check_simple pos v); v (* * Compare two simple values. *) let tag = function ValNone -> 0 | ValInt _ -> 1 | ValFloat _ -> 2 | ValArray _ -> 3 | ValData _ -> 4 | ValNode _ -> 5 | ValDir _ -> 6 | ValOther (ValExitCode _) -> 7 | ValOther (ValLocation _) -> 8 | ValVar _ -> 9 | _ -> raise (Invalid_argument "ValueCompare: value not supported") let rec compare v1 v2 = match v1, v2 with ValNone, ValNone -> 0 | ValInt i1, ValInt i2 | ValOther (ValExitCode i1), ValOther (ValExitCode i2) -> if i1 < i2 then -1 else if i1 > i2 then 1 else 0 | ValFloat x1, ValFloat x2 -> if x1 < x2 then -1 else if x1 > x2 then 1 else 0 | ValArray a1, ValArray a2 -> compare_list a1 a2 | ValData s1, ValData s2 -> Pervasives.compare s1 s2 | ValNode node1, ValNode node2 -> Omake_node.Node.compare node1 node2 | ValDir dir1, ValDir dir2 -> Omake_node.Dir.compare dir1 dir2 | ValOther (ValLocation loc1), ValOther (ValLocation loc2) -> Lm_location.compare loc1 loc2 | ValVar (_, v1), ValVar (_, v2) -> Omake_ir_util.VarInfoCompare.compare v1 v2 | _ -> tag v1 - tag v2 and compare_list l1 l2 = match l1, l2 with v1 :: l1, v2 :: l2 -> let cmp = compare v1 v2 in if cmp = 0 then compare_list l1 l2 else cmp | [], [] -> 0 | [], _ :: _ -> -1 | _ :: _, [] -> 1 end;; module ValueTable = Lm_map.LmMakeRec (ValueCompare);; omake-0.10.3/src/ir/omake_node_type.ml0000644000175000017500000000156513177364665016241 0ustar gerdgerd(* * Types of internal representations of nodes. *) (* * Internally, we represent pathnames as absolute paths. * We keep a hashed integer for quick equality testing. * dir_hash : the quick hash * dir_root : the root of this name * dir_key : the path in canonical form (lowercase on Windows) * dir_name : the actual path will full capitalization *) type dir = | DirRoot of int * Lm_filename_util.root | DirSub of int * string * string * dir (* * Possible node flags. *) type node_flag = NodeIsOptional | NodeIsExisting | NodeIsSquashed | NodeIsScanner (* * A node is a phony, or it is a filename. *) type node = NodeFile of int * dir * string * string | NodePhonyGlobal of int * string | NodePhonyDir of int * dir * string * string | NodePhonyFile of int * dir * string * string * string | NodeFlagged of node_flag * node omake-0.10.3/src/ir/omake_node_sig.ml0000644000175000017500000001107713177364665016041 0ustar gerdgerd module type DirSig = sig type t (* * Some standard directories. *) val lib : t val home : t val root : t (* * Current working directory. *) val cwd : unit -> t val reset_cwd : unit -> unit (* * A new directory. *) val chdir : t -> string -> t (* * Name of this directory relative to another directory. *) val name : t -> t -> string (* * Get the full name relative to the cwd. *) val fullname : t -> string (* * Get the absolute name. * Try not to use this, except for printing. *) val absname : t -> string (* * Check if two directories are equal. *) val equal : t -> t -> bool val compare : t -> t -> int (* * Marshaling. *) val marshal : t -> Lm_marshal.msg val unmarshal : Lm_marshal.msg -> t end (* * Mount flags. *) type mount_option = | MountCopy | MountLink (* * A "mount" specifies a virtual search path for files. * It doesn't specify directories. *) type 'a poly_mount_info = { mount_file_exists : 'a -> bool; mount_file_reset : 'a -> unit; mount_is_dir : 'a -> bool; mount_stat : 'a -> Unix.LargeFile.stats; mount_digest : 'a -> (string * Digest.t) option; (* = Omake_cache_type.digest *) } (* * A "mount" specifies a virtual search path for files. * It doesn't specify directories. *) module type MountSig = sig type node type dir type t (* * Default mount. *) val empty : t (* * Virtual mount of one directory onto another. * mount src dst copy * src: source directory * dst: target directory * copy: if true, auto-copy the files from the source to the target *) val mount : t -> mount_option list -> dir -> dir -> t end (* * Generic kinds of nodes. *) type node_kind = NodePhony | NodeOptional | NodeExists | NodeSquashed | NodeScanner | NodeNormal type phony_ok = PhonyOK (* It is OK to return a phony node *) | PhonyExplicit (* It is OK to return a phony node only when an explicit syntax was used *) | PhonyProhibited (* Returning phony nodes is not allowed *) (* * A file node. There are two kinds of nodes. * "Phony" nodes do not correspond to files. * Regular file nodes have a directory and * filename part. *) module type NodeSig = sig type pre type t type dir type mount (* * Build a regular filename from a directory and string. * It is legal for the string to contain / chars. *) val create_node : t poly_mount_info -> mount -> dir -> string -> t (* * A phony node does not correspond to a file. *) val create_phony_global : string -> t (* * A phony entry in a directory. The string is not a path. *) val create_phony_dir : dir -> string -> t val create_phony_chdir : t -> dir -> t (* * Build a phony node based on a file. *) val create_phony_node : t -> string -> t (* * Escape a node. *) val create_escape : node_kind -> t -> t (* * What kind of node is this? *) val kind : t -> node_kind (* * Get the node, without any modifiers. *) val core : t -> t (* * Get the core node if the node is squashed. *) val unsquash : t -> t (* * Does the node always exist? *) val always_exists : t -> bool (* * Is this node phony? * This is derivable from the "kind" function. *) val is_phony : t -> bool (* * Is this node a real file? * This is derivable from the "kind" function. *) val is_real : t -> bool (* * Get the filename relative to a directory, * in escaped format. *) val name : dir -> t -> string (* * Get the filename relative to the cwd, in escaped format. *) val fullname : t -> string (* * Get the absolute name in escaped format. *) val absname : t -> string (* * Equality testing. *) val equal : t -> t -> bool val compare : t -> t -> int (* * Just the tail. *) val tail : t -> string (* * Directory of the node. *) val dir : t -> dir (* * Hash code for a node. *) val hash : t -> int (* * In some cases, you may need to use a directory * where a node is expected. This produces the node * dir/. *) val node_of_dir : dir -> t (* * Marshaling. *) val marshal : t -> Lm_marshal.msg val unmarshal : Lm_marshal.msg -> t (* * An internal representation of a node (optimization for the set of phony nodes) *) val dest : t -> pre end omake-0.10.3/src/ir/omake_ir_print.ml0000644000175000017500000003362513177364665016103 0ustar gerdgerdlet print_location = Omake_ast_print.print_location let string_override s pp_fun complete buf arg = if complete then pp_fun true buf arg else Lm_printf.pp_print_string buf s (* * Match kind. *) (* let pp_print_match_kind out kind = *) (* let s = *) (* match kind with *) (* Omake_ir.MatchWild -> "switch" *) (* | MatchRegex -> "match" *) (* in *) (* Lm_printf.pp_print_string out s *) (* * Arities. *) let pp_print_arity buf arity = match arity with | Omake_ir.ArityRange (lower, upper) -> Format.fprintf buf "%d..%d" lower upper | ArityExact i -> Lm_printf.pp_print_int buf i | ArityAny -> Lm_printf.pp_print_string buf "varargs" | ArityNone -> Lm_printf.pp_print_int buf 0 (* * Print a list of symbols. *) (* let rec pp_print_symbol_list buf sl = *) (* match sl with *) (* [s] -> *) (* Lm_symbol.pp_print_symbol buf s *) (* | [] -> *) (* () *) (* | s :: sl -> *) (* Format.fprintf buf "%a, %a" Lm_symbol.pp_print_symbol s pp_print_symbol_list sl *) (* * Print a variable definition kind. *) let pp_print_var_def_kind buf kind = let s = match kind with | Omake_ir.VarDefNormal -> "=" | VarDefAppend -> "+=" in Lm_printf.pp_print_string buf s (* * Scope. *) let pp_print_var_scope buf kind = let s = match kind with Omake_ir.VarScopePrivate -> "private." | VarScopeThis -> "this." | VarScopeVirtual -> "public." | VarScopeGlobal -> "global." in Lm_printf.pp_print_string buf s (* * Variables. *) let pp_print_var_info buf v = match v with Omake_ir.VarPrivate (_, v) -> Format.fprintf buf "private.%a" (**) Lm_symbol.pp_print_symbol v | VarThis (_, v) -> Format.fprintf buf "this.%a" (**) Lm_symbol.pp_print_symbol v | VarVirtual (_, v) -> Format.fprintf buf "public.%a" (**) Lm_symbol.pp_print_symbol v | VarGlobal (_, v) -> Format.fprintf buf "global.%a" (**) Lm_symbol.pp_print_symbol v let pp_print_param = pp_print_var_info (* * Print the export info. *) let pp_print_export_item buf item = match item with Omake_ir.ExportRules -> Lm_printf.pp_print_string buf ".RULE" | ExportPhonies -> Lm_printf.pp_print_string buf ".PHONY" | ExportVar v -> pp_print_var_info buf v let rec pp_print_export_items buf items = match items with [item] -> pp_print_export_item buf item | item :: items -> Format.fprintf buf "%a@ %a" pp_print_export_item item pp_print_export_items items | [] -> () let pp_print_export_info buf info = match info with Omake_ir.ExportNone -> () | ExportAll -> Format.fprintf buf "@ export " | ExportList items -> Format.fprintf buf "@ @[export %a@]" pp_print_export_items items (* * Return identifiers. *) let pp_print_return_id buf (loc, s) = Format.fprintf buf "%s (%a)" s Lm_location.pp_print_location loc (* * Print a string expression. *) let rec pp_print_string_exp complete buf s = match s with Omake_ir.NoneString _ -> Format.fprintf buf "" | IntString (_, i) -> Format.fprintf buf "%d" i | FloatString (_, x) -> Format.fprintf buf "%g" x | WhiteString (_, s) -> Format.fprintf buf "'%s'" (String.escaped s) | ConstString (_, s) -> Format.fprintf buf "\"%s\"" (String.escaped s) | KeyApplyString (_, s) -> Format.fprintf buf "$|%s|" s | FunString (_, opt_params, params, e, export) -> Format.fprintf buf "@[(fun %a =>@ %a%a)@]" (**) (pp_print_all_params complete) (opt_params, params) (pp_print_exp_list complete) e pp_print_export_info export | ApplyString (_, v, [], []) -> Format.fprintf buf "@[$(%a)@]" (**) pp_print_var_info v | VarString (_, v) -> Format.fprintf buf "`%a" pp_print_var_info v | ApplyString (_, v, args, kargs) -> Format.fprintf buf "@[$(%a %a)@]" (**) pp_print_var_info v (pp_print_args complete) (args, kargs) | SuperApplyString (_, super, v, [], []) -> Format.fprintf buf "@[$(%a::%a)@]" (**) Lm_symbol.pp_print_symbol super Lm_symbol.pp_print_symbol v | SuperApplyString (_, super, v, args, kargs) -> Format.fprintf buf "@[$(%a::%a %a)@]" (**) Lm_symbol.pp_print_symbol super Lm_symbol.pp_print_symbol v (pp_print_args complete) (args, kargs) | MethodApplyString (_, v, vl, [], []) -> Format.fprintf buf "@[$(%a.%a)@]" (**) pp_print_var_info v Lm_symbol.pp_print_method_name vl | MethodApplyString (_, v, vl, args, kargs) -> Format.fprintf buf "@[$(%a.%a %a)@]" (**) pp_print_var_info v Lm_symbol.pp_print_method_name vl (pp_print_args complete) (args, kargs) | SequenceString (_, sl) -> Format.fprintf buf "@[(%a)@]" (**) (pp_print_string_exp_list complete) sl | ArrayOfString (_, s) -> Format.fprintf buf "@[(array-of-string@ %a)@]" (**) (pp_print_string_exp complete) s | ArrayString (_, sl) -> Format.fprintf buf "@[[|%a|]@]" (**) (pp_print_string_exp_list complete) sl | QuoteString (_, sl) -> Format.fprintf buf "@[(quote %a)@]" (**) (pp_print_string_exp_list complete) sl | QuoteStringString (_, c, sl) -> Format.fprintf buf "@[(quote %c%a%c)@]" (**) c (pp_print_string_exp_list complete) sl c | ObjectString (_, e, export) -> if complete then Format.fprintf buf "@[object@ %a%a@]" (**) (pp_print_exp_list complete) e pp_print_export_info export else Lm_printf.pp_print_string buf "" | BodyString (_, e, export) -> if complete then Format.fprintf buf "@[body@ %a%a@]" (**) (pp_print_exp_list complete) e pp_print_export_info export else Lm_printf.pp_print_string buf "" | ExpString (_, e, export) -> if complete then Format.fprintf buf "@[exp@ %a%a@]" (**) (pp_print_exp_list complete) e pp_print_export_info export else Lm_printf.pp_print_string buf "" | CasesString (_, cases) -> if complete then begin Format.fprintf buf "@[cases:"; List.iter (fun (v, e1, e2, export) -> Format.fprintf buf "@ @[%a %a:@ %a%a@]" (**) Lm_symbol.pp_print_symbol v (pp_print_string_exp complete) e1 (pp_print_exp_list complete) e2 pp_print_export_info export) cases; Format.fprintf buf "@]" end else Lm_printf.pp_print_string buf "" | ThisString _ -> Lm_printf.pp_print_string buf "$" | LazyString (_, e) -> Format.fprintf buf "$`[%a]" (pp_print_string_exp complete) e | LetVarString (_, v, e1, e2) -> Format.fprintf buf "@[let %a = %a in@ %a@]" (**) pp_print_var_info v (pp_print_string_exp complete) e1 (pp_print_string_exp complete) e2 and pp_print_string_exp_list complete buf sl = match sl with [s] -> pp_print_string_exp complete buf s | [] -> () | s :: sl -> Format.fprintf buf "%a,@ %a" (pp_print_string_exp complete) s (pp_print_string_exp_list complete) sl (* * Print a list of symbols. *) and pp_print_curry buf flag = if flag then Lm_printf.pp_print_string buf "curry." and pp_print_params_inner buf sl = match sl with [v] -> pp_print_param buf v | [] -> () | v :: sl -> Format.fprintf buf "%a, " pp_print_param v; pp_print_params_inner buf sl and pp_print_params buf sl = pp_print_params_inner buf sl and pp_print_keyword_param complete buf param = match param with (v1, v2, Some s) -> Format.fprintf buf "@[?%a (%a) =@ %a@]" Lm_symbol.pp_print_symbol v1 pp_print_param v2 (pp_print_string_exp complete) s | (v1, v2, None) -> Format.fprintf buf "@[~%a (%a)@]" Lm_symbol.pp_print_symbol v1 pp_print_param v2 and pp_print_keyword_params complete buf params = match params with [p] -> pp_print_keyword_param complete buf p | p :: params -> Format.fprintf buf "%a,@ " (pp_print_keyword_param complete) p; pp_print_keyword_params complete buf params | [] -> () and pp_print_all_params complete buf = function [], params -> pp_print_params buf params | opt_params, [] -> pp_print_keyword_params complete buf opt_params | opt_params, params -> Format.fprintf buf "%a,@ %a" (pp_print_keyword_params complete) opt_params pp_print_params params and pp_print_normal_args complete buf first args = match args with arg :: args -> if not first then Format.fprintf buf ",@ "; pp_print_string_exp complete buf arg; pp_print_normal_args complete buf false args | [] -> first and pp_print_keyword_args complete buf first args = match args with (v, arg) :: args -> if not first then Format.fprintf buf ",@ "; Format.fprintf buf "%a =@ %a" Lm_symbol.pp_print_symbol v (pp_print_string_exp complete) arg; pp_print_keyword_args complete buf false args | [] -> () and pp_print_args complete buf (args, kargs) = pp_print_keyword_args complete buf (pp_print_normal_args complete buf true args) kargs (* * Print an expression. *) and pp_print_exp complete buf e = if complete && !print_location then Format.fprintf buf "<%a>" Lm_location.pp_print_location (Omake_ir_util.loc_of_exp e); match e with LetVarExp (_, v, vl, kind, s) -> Format.fprintf buf "@[%a%a %a@ %a@]" (**) pp_print_var_info v Lm_symbol.pp_print_method_name vl pp_print_var_def_kind kind (pp_print_string_exp complete) s | LetFunExp (_, v, vl, curry, opt_params, params, el, export) -> Format.fprintf buf "@[%a%a%a(%a) =@ %a%a@]" (**) pp_print_curry curry pp_print_var_info v Lm_symbol.pp_print_method_name vl (pp_print_all_params complete) (opt_params, params) (string_override "<...>" pp_print_exp_list complete) el pp_print_export_info export | LetObjectExp (_, v, vl, s, el, export) -> Format.fprintf buf "@[%a%a. =@ extends %a@ %a%a@]" (**) pp_print_var_info v Lm_symbol.pp_print_method_name vl (pp_print_string_exp complete) s (string_override "<...>" pp_print_exp_list complete) el pp_print_export_info export | LetThisExp (_, e) -> Format.fprintf buf "@[ =@ %a@]" (pp_print_string_exp complete) e | ShellExp (_, e) -> Format.fprintf buf "@[shell(%a)@]" (pp_print_string_exp complete) e | IfExp (_, cases) -> if complete then begin Format.fprintf buf "@[if"; List.iter (fun (s, el, export) -> Format.fprintf buf "@ @[| %a ->@ %a%a@]" (**) (pp_print_string_exp complete) s (pp_print_exp_list complete) el pp_print_export_info export) cases; Format.fprintf buf "@]" end else Lm_printf.pp_print_string buf "" | SequenceExp (_, el) -> Format.fprintf buf "@[sequence@ %a@]" (**) (pp_print_exp_list complete) el | SectionExp (_, s, el, export) -> Format.fprintf buf "@[section %a@ %a%a@]" (**) (pp_print_string_exp complete) s (string_override "<...>" pp_print_exp_list complete) el pp_print_export_info export | OpenExp (_, nodes) -> Format.fprintf buf "@[open"; List.iter (fun node -> Format.fprintf buf "@ %a" Omake_node.pp_print_node node) nodes; Format.fprintf buf "@]" | IncludeExp (_, s, commands) -> Format.fprintf buf "@[include %a:%a@]" (**) (pp_print_string_exp complete) s (pp_print_commands complete) commands | ApplyExp (_, v, args, kargs) -> Format.fprintf buf "@[%a(%a)@]" (**) pp_print_var_info v (pp_print_args complete) (args, kargs) | SuperApplyExp (_, super, v, args, kargs) -> Format.fprintf buf "@[%a::%a(%a)@]" (**) Lm_symbol.pp_print_symbol super Lm_symbol.pp_print_symbol v (pp_print_args complete) (args, kargs) | MethodApplyExp (_, v, vl, args, kargs) -> Format.fprintf buf "@[%a.%a(%a)@]" (**) pp_print_var_info v Lm_symbol.pp_print_method_name vl (pp_print_args complete) (args, kargs) | ReturnBodyExp (_, el, id) -> Format.fprintf buf "@[return-body %a@ %a@]" (**) pp_print_return_id id (string_override "<...>" pp_print_exp_list complete) el | StringExp (_, s) -> Format.fprintf buf "string(%a)" (pp_print_string_exp complete) s | ReturnExp (_, s, id) -> Format.fprintf buf "return(%a) from %a" (**) (pp_print_string_exp complete) s pp_print_return_id id | ReturnSaveExp _ -> Lm_printf.pp_print_string buf "return-current-file" | ReturnObjectExp (_, names) -> Format.fprintf buf "@[return-current-object"; List.iter (fun v -> Format.fprintf buf "@ %a" Lm_symbol.pp_print_symbol v) names; Format.fprintf buf "@]" | KeyExp (_, v) -> Format.fprintf buf "$|%s|" v | LetKeyExp (_, v, kind, s) -> Format.fprintf buf "@[$|%s| %a@ %a@]" (**) v pp_print_var_def_kind kind (pp_print_string_exp complete) s | StaticExp (_, node, key, el) -> Format.fprintf buf "@[static(%a.%a):@ %a@]" (**) Omake_node.pp_print_node node Lm_symbol.pp_print_symbol key (string_override "<...>" pp_print_exp_list complete) el and pp_print_exp_list complete buf el = match el with [e] -> pp_print_exp complete buf e | e :: el -> pp_print_exp complete buf e; Lm_printf.pp_print_space buf (); pp_print_exp_list complete buf el | [] -> () and pp_print_commands complete buf el = List.iter (fun e -> Format.fprintf buf "@ %a" (pp_print_string_exp complete) e) el (* * Print simple parts, abbreviating others as "" *) let pp_print_exp_list_simple = pp_print_exp_list false (* * The complete printers. *) let pp_print_exp = pp_print_exp true let pp_print_string_exp = pp_print_string_exp true let pp_print_string_exp_list = pp_print_string_exp_list true let pp_print_exp_list = pp_print_exp_list true (* let pp_print_prog buf el = *) (* Format.fprintf buf "@[%a@]" pp_print_exp_list el *) omake-0.10.3/src/ir/omake_ir.ml0000644000175000017500000002240713177364665014663 0ustar gerdgerd(* * Define an intermediate representation that is a little * easier to work with than the AST. *) (* GS: translation from AST to IR is in Omake_ir_ast *) (* * %%MAGICBEGIN%% * Last manual IR versioning: 12/09/07 by Aleksey Nogin *) type var = Lm_symbol.t type keyword = Lm_symbol.t type curry_flag = bool (* * Whether a function of zero arguments should be applied. *) type apply_empty_strategy = ApplyEmpty | ApplyNonEmpty (* * Arity of functions. *) type arity = ArityRange of int * int | ArityExact of int | ArityNone | ArityAny (* * Kinds of matches. *) type match_kind = MatchWild | MatchRegex (* * Variable definitions have several forms. * VarDefNormal: normal definition * VarDefAppend: append the text *) type var_def_kind = VarDefNormal | VarDefAppend (* * Simple version of variables includes the kind of * scope, the location, and the variable name. *) type var_info = VarPrivate of Lm_location.t * var | VarThis of Lm_location.t * var | VarVirtual of Lm_location.t * var | VarGlobal of Lm_location.t * var type param = var_info (* * A symbol table maps variables to their info. *) type senv = var_info Lm_symbol.SymbolTable.t (* * Exporting. *) type export_item = ExportRules | ExportPhonies | ExportVar of var_info type export = ExportNone | ExportAll | ExportList of export_item list (* * A return identifier is a unique id for the function to return from. * NOTE: this is a unique string, compared with pointer equality. *) type return_id = Lm_location.t * string (* * Expression that results in a string. * * Functions: a function takes a triple: * keyword_param list : the optional parameters * keyword_set : the set of keywords (for checking against the keyword arguments) * param list : the names of the required parameters * * The ordering of keyword arguments in the source is irrelevant. * Internally, we sort them by symbol name, for easy checking. *) (* GS. I guess this is no longer restricted to strings - it could be any value. *) (* GS: NoneString corresponds to NullExp in the AST. Never programmatically returned IntString = Ast.IntExp FloatString = Ast.StringExp WhiteString = Ast.WhiteString (constant parsing as ws) ConstString = Ast.String{Op|Id|Int|Float|Other|Keyword}String FunString an anonymous function ("v => ..." arguments) ApplyString variable (empty arg list) or function calls. Always eager evaluation. SuperApplyString MethodApplyString SequenceString value sequence (list of words etc.) ArrayString the body of a multiline variable[] definition ArrayOfString the value of a singleline variable[] def, and the value still needs to be split up QuoteString = range quoted with $"" QuoteStringString = range quoted with double quotes ObjectString BodyString marks an arg syntactically given as body (except array args -> ArrayString) ExpString include a general expression (type exp) CasesString KeyApplyString VarString Unclear (variables are represented with ApplyString(...,"varname",[]) ThisString $(this) LazyString result of the transformation for lazy ranges. Lazily evaluated parts are wrapped by LazyString. LetVarString used for internally generated variables (for transformations) *) (* GS. so, QuoteString and QuoteStringString both indicate that the inner expressions are concatenated as plain strings (no sequence structure). The difference is that QuoteString discards the quotes while the quotes of QuoteStringString are kept, e.g. println($"hello world") => prints hello world println("hello world") => prints "hello world" An evaluated QuoteString returns ValData (if it is plain) or ValQuote (if it contains inner structure), whereas QuoteStringString returns ValQuoteString. *) type string_exp = NoneString of Lm_location.t | IntString of Lm_location.t * int | FloatString of Lm_location.t * float | WhiteString of Lm_location.t * string | ConstString of Lm_location.t * string | FunString of Lm_location.t * keyword_param list * param list * exp list * export | ApplyString of Lm_location.t * var_info * string_exp list * keyword_arg list | SuperApplyString of Lm_location.t * var * var * string_exp list * keyword_arg list | MethodApplyString of Lm_location.t * var_info * var list * string_exp list * keyword_arg list | SequenceString of Lm_location.t * string_exp list | ArrayString of Lm_location.t * string_exp list | ArrayOfString of Lm_location.t * string_exp | QuoteString of Lm_location.t * string_exp list | QuoteStringString of Lm_location.t * char * string_exp list | ObjectString of Lm_location.t * exp list * export | BodyString of Lm_location.t * exp list * export | ExpString of Lm_location.t * exp list * export | CasesString of Lm_location.t * (var * string_exp * exp list * export) list | KeyApplyString of Lm_location.t * string | VarString of Lm_location.t * var_info | ThisString of Lm_location.t | LazyString of Lm_location.t * string_exp | LetVarString of Lm_location.t * var_info * string_exp * string_exp and source_exp = Omake_node_sig.node_kind * string_exp and source_table = string_exp Lm_symbol.SymbolTable.t (* * Optional function arguments. *) and keyword_param = var * param * string_exp option (* * Arguments are a pair of normal arguments and keyword arguments. *) and keyword_arg = var * string_exp (* * Commands. *) and rule_command = RuleSection of string_exp * exp | RuleString of string_exp and exp = (* Definitions *) LetVarExp of Lm_location.t * var_info * var list * var_def_kind * string_exp | LetFunExp of Lm_location.t * var_info * var list * curry_flag * keyword_param list * param list * exp list * export | LetObjectExp of Lm_location.t * var_info * var list * string_exp * exp list * export | LetThisExp of Lm_location.t * string_exp | LetKeyExp of Lm_location.t * string * var_def_kind * string_exp (* Applications *) | ApplyExp of Lm_location.t * var_info * string_exp list * keyword_arg list | SuperApplyExp of Lm_location.t * var * var * string_exp list * keyword_arg list | MethodApplyExp of Lm_location.t * var_info * var list * string_exp list * keyword_arg list | KeyExp of Lm_location.t * string (* Sequences *) | SequenceExp of Lm_location.t * exp list | SectionExp of Lm_location.t * string_exp * exp list * export (* StaticExp (Lm_location.t, filename, id, el) *) | StaticExp of Lm_location.t * Omake_node.Node.t * Lm_symbol.t * exp list (* Conditional *) | IfExp of Lm_location.t * (string_exp * exp list * export) list (* Shell command *) | ShellExp of Lm_location.t * string_exp (* * StringExp (loc, s) * This is just an identity, evaluating to s * ReturnExp (loc, s) * This is a control operation, branching to the innermost ReturnBodyExp * ReturnBodyExp (loc, e) * Return to here. *) | StringExp of Lm_location.t * string_exp | ReturnExp of Lm_location.t * string_exp * return_id | ReturnBodyExp of Lm_location.t * exp list * return_id (* * LetOpenExp (loc, v, id, file, link) * id : the current object * file : name of the file/object to open * link : link information for the rest of the variables in scope. *) | OpenExp of Lm_location.t * Omake_node.Node.t list | IncludeExp of Lm_location.t * string_exp * string_exp list (* Return the current object *) | ReturnObjectExp of Lm_location.t * Lm_symbol.t list | ReturnSaveExp of Lm_location.t (* * The IR stored in a file. * ir_classnames : class names of the file * ir_vars : variables defined by this file * ir_exp : the expression *) type t = { ir_classnames : Lm_symbol.t list; ir_vars : senv; ir_exp : exp } (* %%MAGICEND%% *) (* * Variable classes. * private: variables local to the file, statically scoped. * this: object fields, dynamically scoped. * virtual: file fields, dynamically scoped. * global: search each of the scopes in order (ZZZ: 0.9.8 only) *) type var_scope = VarScopePrivate | VarScopeThis | VarScopeVirtual | VarScopeGlobal (************************************************************************ * Simplified variables. *) type simple_var_info = var_scope * var (* Path definitions. *) type name_info = { name_static : bool; name_curry : bool; name_scope : var_scope option } type method_name = | NameEmpty of name_info | NameMethod of name_info * var * var list omake-0.10.3/src/ir/omake_var.ml0000644000175000017500000001745513177364665015050 0ustar gerdgerd(* * Virtual identifiers for various things in files. *) (* * These are all builtin variables. * * ZZZ: in 0.9.8 they are VarGlobal. *) let loc = Lm_location.bogus_loc "Builtin" let create_pervasives_var v = Omake_ir.VarGlobal (loc, v) (* * Generally useful virtual variables. *) let argv_var = create_pervasives_var Omake_symbol.argv_sym let options_var = create_pervasives_var Omake_symbol.options_object_sym let explicit_target_var = create_pervasives_var Omake_symbol.explicit_target_sym let cwd_var = create_pervasives_var Omake_symbol.cwd_sym let stdlib_var = create_pervasives_var Omake_symbol.stdlib_sym let stdroot_var = create_pervasives_var Omake_symbol.stdroot_sym let ostype_var = create_pervasives_var Omake_symbol.ostype_sym let omakepath_var = create_pervasives_var Omake_symbol.omakepath_sym let path_var = create_pervasives_var Omake_symbol.path_sym let auto_rehash_var = create_pervasives_var Omake_symbol.auto_rehash_sym (* let printexitvalue_var = create_pervasives_var Omake_symbol.printexitvalue_sym *) let system_var = create_pervasives_var Omake_symbol.system_sym let oshell_var = create_pervasives_var Omake_symbol.oshell_sym let cdpath_var = create_pervasives_var Omake_symbol.cdpath_sym let history_file_var = create_pervasives_var Omake_symbol.history_file_sym let history_length_var = create_pervasives_var Omake_symbol.history_length_sym let targets_var = create_pervasives_var Omake_symbol.targets_sym let build_summary_var = create_pervasives_var Omake_symbol.build_summary_sym let prompt_var = create_pervasives_var Omake_symbol.prompt_sym let ignoreeof_var = create_pervasives_var Omake_symbol.ignoreeof_sym let exit_on_uncaught_exception_var = create_pervasives_var Omake_symbol.exit_on_uncaught_exception_sym let abort_on_command_error_var = create_pervasives_var Omake_symbol.abort_on_command_error_sym let create_subdirs_var = create_pervasives_var Omake_symbol.create_subdirs_sym let allow_empty_subdirs_var = create_pervasives_var Omake_symbol.allow_empty_subdirs_sym let glob_options_var = create_pervasives_var Omake_symbol.glob_options_sym let glob_ignore_var = create_pervasives_var Omake_symbol.glob_ignore_sym let glob_allow_var = create_pervasives_var Omake_symbol.glob_allow_sym let scanner_mode_var = create_pervasives_var Omake_symbol.scanner_mode_sym let stdin_var = create_pervasives_var Omake_symbol.stdin_sym let stdout_var = create_pervasives_var Omake_symbol.stdout_sym let stderr_var = create_pervasives_var Omake_symbol.stderr_sym let star_var = create_pervasives_var Omake_symbol.star_sym let at_var = create_pervasives_var Omake_symbol.at_sym let gt_var = create_pervasives_var Omake_symbol.gt_sym let plus_var = create_pervasives_var Omake_symbol.plus_sym let hat_var = create_pervasives_var Omake_symbol.hat_sym let lt_var = create_pervasives_var Omake_symbol.lt_sym let amp_var = create_pervasives_var Omake_symbol.amp_sym let braces_var = create_pervasives_var Omake_symbol.braces_sym let fs_var = create_pervasives_var Omake_symbol.fs_sym let rs_var = create_pervasives_var Omake_symbol.rs_sym let filename_var = create_pervasives_var Omake_symbol.filename_sym let fnr_var = create_pervasives_var Omake_symbol.fnr_sym let parse_loc_var = create_pervasives_var Omake_symbol.parse_loc_sym let zero_var = create_pervasives_var Omake_symbol.zero_sym let nf_var = create_pervasives_var Omake_symbol.nf_sym let object_var = create_pervasives_var Omake_symbol.object_sym let int_object_var = create_pervasives_var Omake_symbol.int_object_sym let float_object_var = create_pervasives_var Omake_symbol.float_object_sym let string_object_var = create_pervasives_var Omake_symbol.string_object_sym let sequence_object_var = create_pervasives_var Omake_symbol.sequence_object_sym let array_object_var = create_pervasives_var Omake_symbol.array_object_sym let fun_object_var = create_pervasives_var Omake_symbol.fun_object_sym let rule_object_var = create_pervasives_var Omake_symbol.rule_object_sym let file_object_var = create_pervasives_var Omake_symbol.file_object_sym let dir_object_var = create_pervasives_var Omake_symbol.dir_object_sym let body_object_var = create_pervasives_var Omake_symbol.body_object_sym let in_channel_object_var = create_pervasives_var Omake_symbol.in_channel_object_sym let out_channel_object_var = create_pervasives_var Omake_symbol.out_channel_object_sym let in_out_channel_object_var = create_pervasives_var Omake_symbol.in_out_channel_object_sym let lexer_object_var = create_pervasives_var Omake_symbol.lexer_object_sym let parser_object_var = create_pervasives_var Omake_symbol.parser_object_sym let location_object_var = create_pervasives_var Omake_symbol.location_object_sym let map_object_var = create_pervasives_var Omake_symbol.map_object_sym let shell_object_var = create_pervasives_var Omake_symbol.shell_object_sym let target_object_var = create_pervasives_var Omake_symbol.target_object_sym let stat_object_var = create_pervasives_var Omake_symbol.stat_object_sym let passwd_object_var = create_pervasives_var Omake_symbol.passwd_object_sym let group_object_var = create_pervasives_var Omake_symbol.group_object_sym let pipe_object_var = create_pervasives_var Omake_symbol.pipe_object_sym let select_object_var = create_pervasives_var Omake_symbol.pipe_object_sym let runtime_exception_var = create_pervasives_var Omake_symbol.runtime_exception_sym let var_object_var = create_pervasives_var Omake_symbol.var_object_sym let tm_object_var = create_pervasives_var Omake_symbol.tm_object_sym let extends_var = create_pervasives_var Omake_symbol.extends_sym let omakeflags_var = create_pervasives_var Omake_symbol.omakeflags_sym let omakeargv_var = create_pervasives_var Omake_symbol.omakeargv_sym let printexitvalue_var = create_pervasives_var Omake_symbol.printexitvalue_sym let loc_field_var = Omake_ir.VarThis (loc, Omake_symbol.loc_sym) let builtin_field_var = Omake_ir.VarThis (loc, Omake_symbol.builtin_sym) let map_field_var = Omake_ir.VarThis (loc, Omake_symbol.map_sym) let current_prec_field_var = Omake_ir.VarThis (loc, Omake_symbol.current_prec_sym) let lexer_field_var = Omake_ir.VarThis (loc, Omake_symbol.lexer_sym) let file_var = Omake_ir.VarPrivate (loc, Omake_symbol.file_sym) let file_id_var = Omake_ir.VarPrivate (loc, Omake_symbol.file_id_sym) let wild_var = Omake_ir.VarPrivate (loc, Omake_symbol.wild_sym) (* * Special handling for small numeric vars. *) let create_numeric_var = let numeric_vars = ref [||] in let resize i = let size = (i + 1) * 2 in let table = Array.make size wild_var in for j = 0 to pred size do table.(j) <- create_pervasives_var (Lm_symbol.add (string_of_int j)) done; numeric_vars := table; table in let get i = let table = !numeric_vars in if i < Array.length table then table.(i) else (resize i).(i) in get omake-0.10.3/src/ir/omake_pos.ml0000644000175000017500000000203513177364665015045 0ustar gerdgerd(* Standard exceptions. *) let string_loc = Lm_location.bogus_loc "" let loc_of_item (x : Omake_value_type.item ) = match x with | AstExp e -> Omake_ast_util.loc_of_exp e | IrExp e -> Omake_ir_util.loc_of_exp e | Location loc -> loc | Value _ | Symbol _ | String _ | Error _ -> string_loc module Make (Name : sig val name : string end) = struct include Lm_position.MakePos (struct type t = Omake_value_type.item let name = Name.name let loc_of_t = loc_of_item let pp_print_t = Omake_value_print.pp_print_item end ) (* let loc_pos_pos loc pos = *) (* cons_pos (Location loc) pos *) let ast_exp_pos e = base_pos (AstExp e) let ir_exp_pos e = base_pos (IrExp e) let var_exp_pos v = base_pos (Symbol v) let string_exp_pos s = base_pos (String s) let value_exp_pos v = base_pos (Value v) let var_pos = symbol_pos (* let value_pos v pos = cons_pos (Value v) pos *) let error_pos e pos = cons_pos (Error e) pos end omake-0.10.3/src/ir/omake_node.ml0000644000175000017500000013634613177364665015206 0ustar gerdgerd (* * Internally, we represent pathnames as absolute paths. * We keep a hashed integer for quick equality testing. * dir_root : the root of this name * dir_key : the path in canonical form (lowercase on Windows) * dir_name : the actual path will full capitalization *) (* %%MAGICBEGIN%% *) module rec DirElt : sig type t = | DirRoot of Lm_filename_util.root | DirSub of FileCase.t * string * DirHash.t end = DirElt (* %%MAGICEND%% *) and FileCase : sig type t val create : DirHash.t -> string -> t val compare : t -> t -> int val add_filename : Lm_hash_code.HashCode.t -> t -> unit val add_filename_string : Buffer.t -> t -> unit val marshal : t -> Lm_marshal.msg val unmarshal : Lm_marshal.msg -> t end = struct (* %%MAGICBEGIN%% *) type t = string (* %%MAGICEND%% *) (* Check whether a directory is case-sensitive. *) let case_table = ref DirTable.empty (* * To check for case sensitivity, try these tests in order, * stopping when one is successful. * 1. Try the name being created itself. * 2. Try looking at the directory entries. * 3. Create a dummy file, and test (unless the attept to do step 2 made * us realize there is no such directory). * 4. Test the parent. * * Steps 2-4 will only be performed when we really need them (the name contains * uppercase letters), *) exception Not_a_usable_directory let rec dir_test_sensitivity shortcircuit dir absdir name = try Lm_fs_case_sensitive.stat_with_toggle_case absdir name with Not_found -> if shortcircuit then Lm_fs_case_sensitive.check_already_lowercase name (String.length name) 0; try let dir_handle = try Unix.opendir absdir with Unix.Unix_error ((ENOENT | ENOTDIR | ELOOP | ENAMETOOLONG), _, _) -> raise Not_a_usable_directory in try Lm_fs_case_sensitive.dir_test_all_entries_exn absdir dir_handle with Unix.Unix_error _ | Not_found | End_of_file -> Lm_fs_case_sensitive.dir_test_new_entry_exn absdir with Unix.Unix_error _ | Not_found | End_of_file | Not_a_usable_directory -> match DirHash.get dir with DirRoot _ -> (* Nothing else we can do, assume sensitive *) true | DirSub (_, name, parent) -> dir_is_sensitive false parent name (* * This is the caching version of the case-sensitivity test. *) and dir_is_sensitive shortcircuit dir name = try DirTable.find !case_table dir with Not_found -> let absdir = DirHash.abs_dir_name dir in let sensitive = if Lm_fs_case_sensitive.available then try Lm_fs_case_sensitive.case_sensitive absdir with Failure _ -> dir_test_sensitivity shortcircuit dir absdir name else dir_test_sensitivity shortcircuit dir absdir name in case_table := DirTable.add !case_table dir sensitive; sensitive (* * On Unix-like OS (especially on Mac OS X), create needs to check the fs of the node's parent * directory for case sensitivity. * See also http://bugzilla.metaprl.org/show_bug.cgi?id=657 *) let create = match Sys.os_type with | "Win32" | "Cygwin" -> (fun _ name -> String.lowercase_ascii name) | _ -> (fun dir name -> try if dir_is_sensitive true dir name then name else String.lowercase_ascii name with Lm_fs_case_sensitive.Already_lowercase -> name) let compare = Lm_string_util.string_compare let add_filename = Lm_hash_code.HashCode.add_string let add_filename_string = Buffer.add_string let marshal (s : string) : Lm_marshal.msg = String s let unmarshal (u : Lm_marshal.msg) : string = match u with | String s -> s | _ -> raise Lm_marshal.MarshalError end (** Directories. *) (* * Sets and tables. *) and DirCompare : Lm_hash.MARSHAL_EQ with type t = DirElt.t= struct type t = DirElt.t let debug = "Dir" let fine_hash (x : t) = match x with | DirRoot root -> Hashtbl.hash root | DirSub (_, raw_name, parent) -> let buf = Lm_hash_code.HashCode.create () in Lm_hash_code.HashCode.add_int buf (DirHash.hash parent); Lm_hash_code.HashCode.add_string buf raw_name; Lm_hash_code.HashCode.code buf let coarse_hash (x : t) = match x with | DirRoot root -> Hashtbl.hash root | DirSub (name, _, parent) -> let buf = Lm_hash_code.HashCode.create () in Lm_hash_code.HashCode.add_int buf (DirHash.hash parent); FileCase.add_filename buf name; Lm_hash_code.HashCode.code buf let fine_compare (dir1 : t) (dir2 : t) = match dir1, dir2 with | DirRoot root1, DirRoot root2 -> Pervasives.compare root1 root2 | DirSub (_, name1, parent1), DirSub (_, name2, parent2) -> let cmp = Lm_string_util.string_compare name1 name2 in if cmp = 0 then DirHash.fine_compare parent1 parent2 else cmp | DirRoot _, DirSub _ -> -1 | DirSub _, DirRoot _ -> 1 let coarse_compare (dir1 : t) ( dir2 : t) = match dir1, dir2 with | DirRoot root1, DirRoot root2 -> Pervasives.compare root1 root2 | DirSub (name1, _, parent1), DirSub (name2, _, parent2) -> let cmp = FileCase.compare name1 name2 in if cmp = 0 then DirHash.compare parent1 parent2 else cmp | DirRoot _, DirSub _ -> -1 | DirSub _, DirRoot _ -> 1 let reintern (dir : t) = match dir with | DirRoot _ -> dir | DirSub (name1, name2, parent1) -> let parent2 = DirHash.reintern parent1 in if parent2 == parent1 then dir else DirSub (name1, name2, parent2) end (* %%MAGICBEGIN%% *) and DirHash : sig include Lm_hash.HashMarshalEqSig with type elt = DirElt.t with type t = Lm_hash.MakeFine(DirCompare).t val abs_dir_name : t -> string end = struct include Lm_hash.MakeFine (DirCompare) let abs_dir_name : t -> string = let rec name buf dir = match get dir with DirRoot root -> Buffer.add_string buf (Lm_filename_util.string_of_root root) | DirSub (key, _, parent) -> name buf parent; begin match get parent with | DirRoot _ -> () | _ -> Buffer.add_string buf Filename.dir_sep end; FileCase.add_filename_string buf key in fun dir -> let buf = Buffer.create 17 in let () = name buf dir in Buffer.contents buf end and DirSet : Lm_set_sig.LmSet with type elt = DirHash.t = Lm_set.LmMake (DirHash) and DirTable : Lm_map_sig.LmMap with type key = DirHash.t = Lm_map.LmMake (DirHash) (* %%MAGICEND%% *) (* * Lists of directories. *) module rec DirListCompare : Lm_hash.MARSHAL_EQ with type t = DirHash.t list = struct type t = DirHash.t list let debug = "DirList" let fine_hash = Lm_hash_code.hash_list DirHash.fine_hash let coarse_hash = Lm_hash_code.hash_list DirHash.hash let rec compare f (l1 : t) (l2 : t) = match l1, l2 with | d1 :: l1, d2 :: l2 -> let cmp = f d1 d2 in if cmp = 0 then compare f l1 l2 else cmp | [], [] -> 0 | [], _ :: _ -> -1 | _ :: _, [] -> 1 let fine_compare = compare DirHash.fine_compare let coarse_compare = compare DirHash.compare let reintern l = Lm_list_util.smap DirHash.reintern l end and DirListHash : Lm_hash.HashMarshalEqSig with type elt = DirHash.t list = Lm_hash.MakeFine (DirListCompare);; module DirListSet = Lm_set.LmMake (DirListHash) module DirListTable = Lm_map.LmMake (DirListHash) (************************************************************************ * Nodes. *) (* * Possible node flags. *) (* %%MAGICBEGIN%% *) type node_flag = | NodeIsOptional | NodeIsExisting | NodeIsSquashed | NodeIsScanner (* * A node is a phony, or it is a filename. *) module rec NodeElt : sig type t = | NodeFile of DirHash.t * FileCase.t * string | NodePhonyGlobal of string | NodePhonyDir of DirHash.t * FileCase.t * string | NodePhonyFile of DirHash.t * FileCase.t * string * string | NodeFlagged of node_flag * NodeHash.t end = NodeElt (* %%MAGICEND%% *) and NodeCompare : sig include Lm_hash.MARSHAL_EQ with type t = NodeElt.t (* Include the default "compare" for the PreNodeSet *) val compare : t -> t -> int end = struct type t = NodeElt.t let debug = "Node" type code = | CodeSpace | CodeEnd | CodeNodeFile | CodeNodePhonyGlobal | CodeNodePhonyDir | CodeNodePhonyFile | CodeNodeFlagged | CodeNodeIsOptional | CodeNodeIsExisting | CodeNodeIsSquashed | CodeNodeIsScanner let add_code buf (code : code) = Lm_hash_code.HashCode.add_bits buf (Obj.magic code) let add_flag_code buf code = let code = match code with NodeIsOptional -> CodeNodeIsOptional | NodeIsExisting -> CodeNodeIsExisting | NodeIsSquashed -> CodeNodeIsSquashed | NodeIsScanner -> CodeNodeIsScanner in add_code buf code module MakeNodeOps (Arg : sig val add_dir : Lm_hash_code.HashCode.t -> DirHash.t -> unit val add_node : Lm_hash_code.HashCode.t -> NodeHash.t -> unit val add_filename : Lm_hash_code.HashCode.t -> FileCase.t -> string -> unit val filename_compare : FileCase.t -> string -> FileCase.t -> string -> int val node_compare : NodeHash.t -> NodeHash.t -> int val dir_compare : DirHash.t -> DirHash.t -> int end) = struct open Arg let add_node buf (node : NodeElt.t) = match node with |NodeFile (dir, name, raw_name) -> add_code buf CodeNodeFile; add_dir buf dir; add_code buf CodeSpace; add_filename buf name raw_name; add_code buf CodeEnd | NodePhonyGlobal name -> add_code buf CodeNodePhonyGlobal; Lm_hash_code.HashCode.add_string buf name; add_code buf CodeEnd | NodePhonyDir (dir, name, raw_name) -> add_code buf CodeNodePhonyDir; add_dir buf dir; add_code buf CodeSpace; add_filename buf name raw_name; add_code buf CodeEnd | NodePhonyFile (dir, key, raw_name, name) -> add_code buf CodeNodePhonyFile; add_dir buf dir; add_code buf CodeSpace; add_filename buf key raw_name; add_code buf CodeSpace; Lm_hash_code.HashCode.add_string buf name; add_code buf CodeEnd | NodeFlagged (flag, node) -> add_code buf CodeNodeFlagged; add_flag_code buf flag; add_code buf CodeSpace; add_node buf node; add_code buf CodeEnd let hash node = let buf = Lm_hash_code.HashCode.create () in add_node buf node; Lm_hash_code.HashCode.code buf let compare_flags flag1 flag2 = match flag1, flag2 with NodeIsOptional, NodeIsOptional | NodeIsExisting, NodeIsExisting | NodeIsSquashed, NodeIsSquashed | NodeIsScanner, NodeIsScanner -> 0 | NodeIsOptional, NodeIsExisting | NodeIsOptional, NodeIsSquashed | NodeIsOptional, NodeIsScanner | NodeIsExisting, NodeIsSquashed | NodeIsExisting, NodeIsScanner | NodeIsSquashed, NodeIsScanner -> -1 | NodeIsExisting, NodeIsOptional | NodeIsSquashed, NodeIsOptional | NodeIsScanner, NodeIsOptional | NodeIsSquashed, NodeIsExisting | NodeIsScanner, NodeIsExisting | NodeIsScanner, NodeIsSquashed -> 1 let compare (node1 : NodeElt.t) (node2 : NodeElt.t) = match node1, node2 with | NodeFile (dir1, key1, name1), NodeFile (dir2, key2, name2) | NodePhonyDir (dir1, key1, name1), NodePhonyDir (dir2, key2, name2) -> let cmp = filename_compare key1 name1 key2 name2 in if cmp = 0 then dir_compare dir1 dir2 else cmp | NodePhonyGlobal name1, NodePhonyGlobal name2 -> Lm_string_util.string_compare name1 name2 | NodePhonyFile (dir1, key1, name1, exname1), NodePhonyFile (dir2, key2, name2, exname2) -> let cmp = Lm_string_util.string_compare exname1 exname2 in if cmp = 0 then let cmp = filename_compare key1 name1 key2 name2 in if cmp = 0 then dir_compare dir1 dir2 else cmp else cmp | NodeFlagged (flag1, node1), NodeFlagged (flag2, _) -> let cmp = compare_flags flag1 flag2 in if cmp = 0 then node_compare node1 node1 (* TODO bug? *) else cmp | NodeFile _, NodePhonyGlobal _ | NodeFile _, NodePhonyDir _ | NodeFile _, NodePhonyFile _ | NodeFile _, NodeFlagged _ | NodePhonyGlobal _, NodePhonyDir _ | NodePhonyGlobal _, NodePhonyFile _ | NodePhonyGlobal _, NodeFlagged _ | NodePhonyDir _, NodePhonyFile _ | NodePhonyDir _, NodeFlagged _ | NodePhonyFile _, NodeFlagged _ -> -1 | NodeFlagged _, NodeFile _ | NodePhonyGlobal _, NodeFile _ | NodePhonyDir _, NodeFile _ | NodePhonyFile _, NodeFile _ | NodeFlagged _, NodePhonyGlobal _ | NodePhonyDir _, NodePhonyGlobal _ | NodePhonyFile _, NodePhonyGlobal _ | NodeFlagged _, NodePhonyDir _ | NodePhonyFile _, NodePhonyDir _ | NodeFlagged _, NodePhonyFile _ -> 1 end;; (* * These operations are case insensitive on case-insensitive * filesystems. They use the canonical FileCase.t name. *) module Ops = MakeNodeOps (struct let add_dir buf dir = Lm_hash_code.HashCode.add_int buf (DirHash.hash dir ) let add_node buf node = Lm_hash_code.HashCode.add_int buf (NodeHash.hash node) let add_filename buf name _raw_name = FileCase.add_filename buf name let filename_compare name1 _raw_name1 name2 _raw_name2 = FileCase.compare name1 name2 let node_compare = NodeHash.compare let dir_compare = DirHash.compare end);; (* * These operations are always case-sensitive. *) module FineOps = MakeNodeOps (struct let add_dir buf dir = Lm_hash_code.HashCode.add_int buf (DirHash.fine_hash dir ) let add_node buf node = Lm_hash_code.HashCode.add_int buf (NodeHash.fine_hash node) let add_filename buf _name raw_name = Lm_hash_code.HashCode.add_string buf raw_name let filename_compare _name1 raw_name1 _name2 raw_name2 = String.compare raw_name1 raw_name2 let node_compare = NodeHash.fine_compare let dir_compare = DirHash.fine_compare end);; let coarse_compare = Ops.compare let coarse_hash = Ops.hash let fine_compare = FineOps.compare let fine_hash = FineOps.hash let compare = Ops.compare (* for the PreNodeSet *) let reintern (node : NodeElt.t) = match node with | NodeFile (dir1, key, name) -> let dir2 = DirHash.reintern dir1 in if dir2 == dir1 then node else NodeFile (dir2, key, name) | NodePhonyDir (dir1, key, name) -> let dir2 = DirHash.reintern dir1 in if dir2 == dir1 then node else NodePhonyDir (dir2, key, name) | NodePhonyFile (dir1, key, name1, name2) -> let dir2 = DirHash.reintern dir1 in if dir2 == dir1 then node else NodePhonyFile (dir2, key, name1, name2) | NodePhonyGlobal _ -> node | NodeFlagged (flag, node1) -> let node2 = NodeHash.reintern node1 in if node2 == node1 then node else NodeFlagged (flag, node2) end (* %%MAGICBEGIN%% *) and NodeHash : Lm_hash.HashMarshalEqSig with type elt = NodeElt.t with type t = Lm_hash.MakeFine(NodeCompare).t = Lm_hash.MakeFine (NodeCompare);; type node = NodeHash.t (* %%MAGICEND%% *) module NodeSet = Lm_set.LmMake (NodeHash);; module NodeTable = Lm_map.LmMake (NodeHash);; module NodeMTable = Lm_map.LmMakeList (NodeHash);; module PreNodeSet = Lm_set.LmMake (NodeCompare);; (************************************************************************ * Implementation. *) (* * Get a pathname from a directory. * The name must be reversed. *) let rec path_of_dir_aux keypath path dir = match DirHash.get dir with DirRoot root -> root, keypath, path | DirSub (key, name, parent) -> path_of_dir_aux (key :: keypath) (name :: path) parent let path_of_dir dir = path_of_dir_aux [] [] dir (* * Build a list of the directories, in reverse order. *) let dir_list_of_dir dir = let rec dir_list_of_dir path dir = match DirHash.get dir with DirRoot _ -> dir :: path | DirSub (_, _, parent) -> dir_list_of_dir (dir :: path) parent in dir_list_of_dir [] dir (* * Produce a path (a string list) from the dir list. *) let rec path_of_dir_list dirs = match dirs with [] -> [] | dir :: dirs -> match DirHash.get dir with DirSub (_, name, _) -> name :: path_of_dir_list dirs | DirRoot _ -> raise (Invalid_argument "path_of_dir_list") (* * Make a directory node from the pathname. *) let make_subdir parent name = DirHash.create (DirSub (FileCase.create parent name, name, parent)) let make_dir root path = List.fold_left make_subdir (DirHash.create (DirRoot root)) path (* * Get the current absolute name of the working directory. *) let getcwd () = let cwd = Unix.getcwd () in match Lm_filename_util.filename_path cwd with AbsolutePath (root, dir) -> make_dir root dir | RelativePath _dir -> raise (Invalid_argument "Unix.getcwd returned a relative path") (* * A null root directory for globals. *) let null_root = make_dir Lm_filename_util.null_root [] (* * Fake root for "absname" computations *) let impossible_root = make_dir (DriveRoot '$') [] (* * Split the directory name into a path. *) let rec path_simplify dir = function "" :: path | "." :: path -> path_simplify dir path | ".." :: path -> let dir = match DirHash.get dir with DirSub (_, _, parent) -> parent | DirRoot _ -> dir in path_simplify dir path | [name] -> dir, Some name | name :: path -> path_simplify (make_subdir dir name) path | [] -> dir, None let new_path dir path = match Lm_filename_util.filename_path path with AbsolutePath (root, path) -> (* This is an absolute path, so ignore the directory *) path_simplify (make_dir root []) path | RelativePath path -> (* This is relative to the directory *) path_simplify dir path let new_dir dir path = match new_path dir path with dir, None -> dir | dir, Some name -> make_subdir dir name let new_file dir path = let dir, name = new_path dir path in match name with Some name -> let key = FileCase.create dir name in dir, key, name | None -> begin match DirHash.get dir with DirSub (key, name, dir) -> dir, key, name | DirRoot _ -> let name = "." in let key = FileCase.create dir name in dir, key, name end (* * Check if .. works in a directory. *) let dotdot_table = ref DirTable.empty (* * Force dotdot to fail. *) let make_dotdot_fail dir = dotdot_table := DirTable.add !dotdot_table dir true let dotdot_fails dir = let table = !dotdot_table in try DirTable.find table dir with Not_found -> let name = DirHash.abs_dir_name dir in let islink = try (Unix.lstat name).Unix.st_kind = Unix.S_LNK with Unix.Unix_error _ -> false in let table = DirTable.add table dir islink in dotdot_table := table; islink (* * Produce string filename for the path, * relative to a particular directory. * * Algorithm: * 1. Compute the common prefix between the directory and file * 2. Add as many ".." as there are remaining names in the directory * and concatenate the rest of the path. * * Example: * dir = /a/b/c/d * path = /a/b/e/f/g * result = ../../e/f/g *) (* * Create a string from the list of strings. *) let rec flatten_generic (add_string : 'a -> string -> 'a) (contents : 'a -> string) (buf : 'a) (path : string list) = match path with [path] -> let buf = add_string buf path in contents buf | [] -> contents buf | name :: path -> let buf = add_string buf name in let buf = add_string buf Filename.dir_sep in flatten_generic add_string contents buf path (* * Add .. to get out of the directory and down into the path. *) let updirs_generic add_string contents buf dirs1 dirs2 = (* Abort if any of the dotdots fail *) if List.exists dotdot_fails dirs1 then None else (* Prepend the .. sequence *) let rec updirs dirs path = match dirs with _ :: dirs -> updirs dirs (".." :: path) | [] -> path in let path = path_of_dir_list dirs2 in let path = updirs dirs1 path in Some (flatten_generic add_string contents buf path) (* * Compute the path of dir2 relative to dir1. *) let rec relocate_generic add_string contents buf (dirs1 : DirHash.t list) (dirs2 : DirHash.t list) = match dirs1, dirs2 with | [], _ -> Some (flatten_generic add_string contents buf (path_of_dir_list dirs2)) | _, [] -> updirs_generic add_string contents buf dirs1 dirs2 | dir1 :: dirs1', dir2 :: dirs2' -> if DirHash.equal dir1 dir2 then relocate_generic add_string contents buf dirs1' dirs2' else updirs_generic add_string contents buf dirs1 dirs2 (* * If the files differ in the root directory, just use the absolute path. *) let relocate_generic add_string contents buf dir1 dir2 = let dirs1 = dir_list_of_dir dir1 in let dirs2 = dir_list_of_dir dir2 in match dirs1, dirs2 with dir1 :: dirs1, dir2 :: dirs2 -> (match DirHash.get dir1, DirHash.get dir2 with DirRoot root1, DirRoot root2 -> (let s = if dirs1 = [] || root1 <> root2 then None else relocate_generic add_string contents buf dirs1 dirs2 in match s with Some s -> s | None -> let buf = add_string buf (Lm_filename_util.string_of_root root2) in let path2 = path_of_dir_list dirs2 in flatten_generic add_string contents buf path2) | _ -> raise (Invalid_argument "relocate_generic")) | _ -> raise (Invalid_argument "relocate_generic") (* * Directory versions. *) let dir_buffer = Buffer.create 17 let dir_add_string buf s = Buffer.add_string buf s; buf let dir_contents buf = let s = Buffer.contents buf in Buffer.clear buf; s let flatten_dir dir = flatten_generic dir_add_string dir_contents dir_buffer dir let relocate_dir dir1 dir2 = relocate_generic dir_add_string dir_contents dir_buffer dir1 dir2 (* * File version. *) let file_contents name buf = let len = Buffer.length buf in let buf = if len = 0 || Buffer.nth buf (len - 1) = Filename.dir_sep.[0] then buf else dir_add_string buf Filename.dir_sep in let buf = dir_add_string buf name in dir_contents buf (* let flatten_file dir name = *) (* let buf = dir_add_string dir_buffer Filename.dir_sep in *) (* flatten_generic dir_add_string (file_contents name) buf dir *) let relocate_file dir1 dir2 name = if DirHash.equal dir1 dir2 then name else relocate_generic dir_add_string (file_contents name) dir_buffer dir1 dir2 (* * Apply a mount point. *) let rec resolve_mount_dir dir_dst dir_src dir = if DirHash.compare dir dir_dst = 0 then dir_src else match DirHash.get dir with DirRoot _ -> raise Not_found | DirSub (key, name, parent) -> let parent = resolve_mount_dir dir_dst dir_src parent in DirHash.create (DirSub (key, name, parent)) let rec resolve_mount_node dir_dst dir_src node = let node : NodeElt.t = match NodeHash.get node with | NodeFile (dir, key, name) -> let dir = resolve_mount_dir dir_dst dir_src dir in NodeFile (dir, key, name) | NodePhonyDir (dir, key, name) -> let dir = resolve_mount_dir dir_dst dir_src dir in NodePhonyDir (dir, key, name) | NodePhonyFile (dir, key1, name1, name) -> let dir = resolve_mount_dir dir_dst dir_src dir in NodePhonyFile (dir, key1, name1, name) | NodePhonyGlobal _ -> raise Not_found | NodeFlagged (flag, node) -> NodeFlagged (flag, resolve_mount_node dir_dst dir_src node) in NodeHash.create node (* * A name can stand for a global phony only if it has no slashes, * or it only leads with a slash. Raises Not_found if the name * contains any non-leading slashes. *) type phony_name = PhonyGlobalString of string | PhonyDirString of string | PhonySimpleString of string | PhonyPathString of string (* Starting at position i, s begins with ".PHONY/" *) let string_prefix_phony s i len = len >= i + 7 && s.[i ] = '.' && s.[i+1] = 'P' && s.[i+2] = 'H' && s.[i+3] = 'O' && s.[i+4] = 'N' && s.[i+5] = 'Y' && (s.[i+6] = '/' || s.[i+6] = '\\') let rec is_simple_string s len i = (i = len) || match s.[i] with '/' | '\\' -> false | _ -> is_simple_string s len (succ i) let parse_phony_name s = let len = String.length s in if len = 0 then PhonySimpleString s else match s.[0] with '/' | '\\' -> if string_prefix_phony s 1 len && is_simple_string s len 8 then (* /.PHONY/foo *) PhonyGlobalString (String.sub s 8 (len - 8)) else PhonyPathString s | '.' when string_prefix_phony s 0 len -> (* .PHONY/foo/bar *) PhonyDirString (String.sub s 7 (len - 7)) | _ -> if is_simple_string s len 1 then PhonySimpleString s else PhonyPathString s (************************************************************************ * Modules. *) module Dir = struct type t = DirHash.t (* * We assume the cwd does not change * once we first get it. *) let cwd_ref = let dir = try getcwd () with Unix.Unix_error (err, _, _) -> Lm_printf.eprintf "@[*** omake: warning:@ Can not find out the current directory:@ %s;@ Using the root directory instead.@]@." (Unix.error_message err); null_root in ref dir (* * Default is current working directory. *) let cwd () = !cwd_ref let reset_cwd () = let cwd = getcwd () in cwd_ref := getcwd (); make_dotdot_fail cwd (* * Building a new path. *) let chdir = new_dir (* * Name, relative to the cwd. *) let name dir1 dir2 = if DirHash.equal dir1 dir2 then "." else relocate_dir dir1 dir2 (* * Name relative to the root. *) let fullname dir = name !cwd_ref dir (* * Absolute name. *) let root = null_root let absname dir = name impossible_root dir (* * Library directory is relative to the root. *) let lib = match Lm_filename_util.filename_path Omake_state.lib_dir with AbsolutePath (root, dir) -> make_dir root dir | RelativePath _ -> raise (Invalid_argument ("Omake_node.lib_dir specified as relative path: " ^ Omake_state.lib_dir)) (* * home directory is also relative to the root. *) let home = match Lm_filename_util.filename_path Omake_state.home_dir with AbsolutePath (root, dir) -> make_dir root dir | RelativePath _ -> raise (Invalid_argument ("Omake_node.home_dir specified as relative path: " ^ Omake_state.home_dir)) let () = make_dotdot_fail root; make_dotdot_fail home (* * Equality. *) let compare = DirHash.compare let equal = DirHash.equal (* * Marshaling. *) let marshal_root (root : Lm_filename_util.root) : Lm_marshal.msg = match root with | NullRoot -> Magic NullRootMagic | DriveRoot c -> List [Magic DriveRootMagic; Char c] let unmarshal_root (l : Lm_marshal.msg) = match l with | Magic NullRootMagic -> Lm_filename_util.NullRoot | List [Magic DriveRootMagic; Char c] -> DriveRoot c | _ -> raise Lm_marshal.MarshalError let rec marshal (dir : DirHash.t) : Lm_marshal.msg = match DirHash.get dir with DirRoot root -> List [Magic Lm_marshal.DirRootMagic; marshal_root root] | DirSub (key, name, parent) -> List [Magic DirSubMagic; FileCase.marshal key; String name; marshal parent] let rec unmarshal (l : Lm_marshal.msg) : DirHash.t = let dir : DirElt.t = match l with | List [Magic Lm_marshal.DirRootMagic; root] -> DirRoot (unmarshal_root root) | List [Magic DirSubMagic; key; String name; parent] -> DirSub (FileCase.unmarshal key, name, unmarshal parent) | _ -> raise Lm_marshal.MarshalError in DirHash.create dir end;; (* * Virtual mounts. * We need a function that checks if a file exists. *) module Mount = struct type t = (Dir.t * Dir.t * Omake_node_sig.mount_option list) list type dir_tmp = DirHash.t type node_tmp = node type dir = dir_tmp type node = node_tmp (* Create a new mount state. *) let empty = [] (* Add a mount point. *) let mount info options dir_src dir_dst = (dir_dst, dir_src, options) :: info end;; type mount_info = node Omake_node_sig.poly_mount_info let no_mount_info = { Omake_node_sig.mount_file_exists = (fun _ -> false); mount_file_reset = (fun _ -> ()); mount_is_dir = (fun _ -> false); mount_stat = (fun _ -> raise (Invalid_argument "no_mount_info")); mount_digest = (fun _ -> None) } module Node = struct type pre = NodeElt.t type t = node type dir = Dir.t type mount = Mount.t let dest = NodeHash.get let phony_name name = "<" ^ name ^ ">" (* * Name of the node. *) let rec name dir1 node = match NodeHash.get node with NodePhonyGlobal name -> phony_name name | NodePhonyDir (dir2, _, name) -> phony_name (relocate_file dir1 dir2 name) | NodePhonyFile (dir2, _, name1, name2) -> phony_name (relocate_file dir1 dir2 name1 ^ ":" ^ name2) | NodeFile (dir2, _, name) -> relocate_file dir1 dir2 name | NodeFlagged (_, node) -> name dir1 node (* * Create a phony name. *) let create_phony_global name = NodeHash.create (NodePhonyGlobal name) (* * Create a phony from a dir. *) let create_phony_dir dir name = let key = FileCase.create dir name in NodeHash.create (NodePhonyDir (dir, key, name)) (* * Create a phony with a new directory. *) let create_phony_chdir node dir = match NodeHash.get node with NodePhonyDir (_, _, name) -> create_phony_dir dir name | _ -> node (* * Create a new phony node from a previous node. * These are not interned. *) let rec create_phony_node node name = match NodeHash.get node with NodeFile (dir, key1, name1) -> NodeHash.create (NodePhonyFile (dir, key1, name1, name)) | NodePhonyGlobal name1 -> let key1 = FileCase.create null_root name1 in NodeHash.create (NodePhonyFile (null_root, key1, name1, name)) | NodePhonyDir (dir, key1, name1) | NodePhonyFile (dir, key1, name1, _) -> NodeHash.create (NodePhonyFile (dir, key1, name1, name)) | NodeFlagged (_, node) -> create_phony_node node name (* * Get the core node. *) let rec core node = match NodeHash.get node with NodePhonyGlobal _ | NodePhonyDir _ | NodePhonyFile _ | NodeFile _ -> node | NodeFlagged (_, node) -> core node (* * Escape a node. *) let create_escape kind node = let node = core node in match kind with | Omake_node_sig.NodeNormal -> node | NodePhony -> raise (Invalid_argument "Omake_node.Node.escape: NodePhony is not allowed") | NodeOptional -> NodeHash.create (NodeFlagged (NodeIsOptional, node)) | NodeExists -> NodeHash.create (NodeFlagged (NodeIsExisting, node)) | NodeSquashed -> NodeHash.create (NodeFlagged (NodeIsSquashed, node)) | NodeScanner -> NodeHash.create (NodeFlagged (NodeIsScanner, node)) (* * Hash code for a node. *) let hash = NodeHash.hash (* * For building targets, we sometimes want to know the * original node. *) let rec unsquash node = match NodeHash.get node with NodePhonyGlobal _ | NodePhonyDir _ | NodePhonyFile _ | NodeFile _ | NodeFlagged (NodeIsOptional, _) | NodeFlagged (NodeIsScanner, _) | NodeFlagged (NodeIsExisting, _) -> node | NodeFlagged (NodeIsSquashed, node) -> unsquash node (* * Kind of the node. *) let kind node = match NodeHash.get node with NodePhonyGlobal _ | NodePhonyDir _ | NodePhonyFile _ -> Omake_node_sig.NodePhony | NodeFile _ -> NodeNormal | NodeFlagged (NodeIsOptional, _) -> NodeOptional | NodeFlagged (NodeIsExisting, _) -> NodeExists | NodeFlagged (NodeIsSquashed, _) -> NodeSquashed | NodeFlagged (NodeIsScanner, _) -> NodeScanner (* * Phony nodes. *) let is_phony node = match NodeHash.get node with NodePhonyGlobal _ | NodePhonyDir _ | NodePhonyFile _ -> true | NodeFile _ | NodeFlagged _ -> false (* let rec phony_name node = *) (* match NodeHash.get node with *) (* NodePhonyGlobal name *) (* | NodePhonyDir (_, _, name) *) (* | NodePhonyFile (_, _, _, name) -> *) (* name *) (* | NodeFile _ -> *) (* raise (Invalid_argument "phony_name") *) (* | NodeFlagged (_, node) -> *) (* phony_name node *) let rec is_real node = match NodeHash.get node with NodePhonyGlobal _ | NodePhonyDir _ | NodePhonyFile _ | NodeFlagged (NodeIsOptional, _) | NodeFlagged (NodeIsExisting, _) -> false | NodeFile _ -> true | NodeFlagged (NodeIsSquashed, node) | NodeFlagged (NodeIsScanner, node) -> is_real node (* * Existential flag. *) let always_exists node = match NodeHash.get node with NodeFlagged (NodeIsOptional, _) | NodeFlagged (NodeIsExisting, _) -> true | NodeFlagged (NodeIsSquashed, _) | NodeFlagged (NodeIsScanner, _) | NodePhonyGlobal _ | NodePhonyDir _ | NodePhonyFile _ | NodeFile _ -> false (* * Just the tail name. *) let rec tail node = match NodeHash.get node with NodePhonyGlobal name | NodePhonyDir (_, _, name) | NodePhonyFile (_, _, _, name) | NodeFile (_, _, name) -> name | NodeFlagged (_, node) -> tail node (* * Get the name of the directory. *) let rec dir node = match NodeHash.get node with NodePhonyGlobal _ -> null_root | NodePhonyDir (dir, _, _) | NodePhonyFile (dir, _, _, _) | NodeFile (dir, _, _) -> dir | NodeFlagged (_, node) -> dir node (* * Equality testing. *) let compare = NodeHash.compare let equal = NodeHash.equal (* * Flags. *) let marshal_flag : node_flag -> Lm_marshal.msg = function NodeIsOptional -> Magic Lm_marshal.NodeIsOptionalMagic | NodeIsExisting -> Magic NodeIsExistingMagic | NodeIsSquashed -> Magic NodeIsSquashedMagic | NodeIsScanner -> Magic NodeIsScannerMagic let unmarshal_flag (flag : Lm_marshal.msg) : node_flag = match flag with | Magic NodeIsOptionalMagic -> NodeIsOptional | Magic NodeIsExistingMagic -> NodeIsExisting | Magic NodeIsSquashedMagic -> NodeIsSquashed | Magic NodeIsScannerMagic -> NodeIsScanner | _ -> raise Lm_marshal.MarshalError (* * Marshaling. *) let rec marshal node : Lm_marshal.msg = match NodeHash.get node with | NodeFile (dir, name1, name2) -> List [Magic NodeFileMagic; Dir.marshal dir; FileCase.marshal name1; String name2] | NodePhonyGlobal s -> List [Magic NodePhonyGlobalMagic; String s] | NodePhonyDir (dir, name1, name2) -> List [Magic NodePhonyDirMagic; Dir.marshal dir; FileCase.marshal name1; String name2] | NodePhonyFile (dir, name1, name2, name3) -> List [Magic NodePhonyFileMagic; Dir.marshal dir; FileCase.marshal name1; String name2; String name3] | NodeFlagged (flag, node) -> List [Magic NodeFlaggedMagic; marshal_flag flag; marshal node] let rec unmarshal (l : Lm_marshal.msg) = let node : NodeElt.t = match l with | List [Magic Lm_marshal.NodeFileMagic; dir; name1; String name2] -> NodeFile (Dir.unmarshal dir, FileCase.unmarshal name1, name2) | List [Magic NodePhonyGlobalMagic; String s] -> NodePhonyGlobal s | List [Magic NodePhonyDirMagic; dir; name1; String name2] -> NodePhonyDir (Dir.unmarshal dir, FileCase.unmarshal name1, name2) | List [Magic NodePhonyFileMagic; dir; name1; String name2; String name3] -> NodePhonyFile (Dir.unmarshal dir, FileCase.unmarshal name1, name2, name3) | List [Magic NodeFlaggedMagic; flag; node] -> NodeFlagged (unmarshal_flag flag, unmarshal node) | _ -> raise Lm_marshal.MarshalError in NodeHash.create node (* * This is a hack to allow Omake_cache to take stats of directories. *) let node_of_dir dir = let name = "." in NodeHash.create (NodeFile (dir, FileCase.create dir name, name)) (* * Full name is relative to the cwd. *) let fullname node = name (Dir.cwd ()) node let absname node = name impossible_root node (************************************************************************ * Mount point handling. *) let unlink_file filename = try Unix.unlink filename with Unix.Unix_error _ -> () let copy_file mount_info src dst = if mount_info.Omake_node_sig.mount_is_dir src then begin if not (mount_info.mount_is_dir dst) then begin Lm_filename_util.mkdirhier (fullname dst) 0o777; mount_info.mount_file_reset dst end end else let src_digest = mount_info.mount_digest src in let dst_digest = mount_info.mount_digest dst in if src_digest <> dst_digest then let dir = dir dst in let mode = (mount_info.mount_stat src).Unix.LargeFile.st_perm in Lm_filename_util.mkdirhier (Dir.fullname dir) 0o777; Lm_unix_util.copy_file (absname src) (absname dst) mode; mount_info.mount_file_reset dst let symlink_file_unix mount_info src dst = if mount_info.Omake_node_sig.mount_is_dir src then begin if not (mount_info.mount_is_dir dst) then begin Lm_filename_util.mkdirhier (fullname dst) 0o777; mount_info.mount_file_reset dst end end else let src_digest = mount_info.mount_digest src in let dst_digest = mount_info.mount_digest dst in if src_digest <> dst_digest then let dir = dir dst in let src_name = name dir src in let dst_name = fullname dst in Lm_filename_util.mkdirhier (Dir.fullname dir) 0o777; unlink_file dst_name; Unix.symlink src_name dst_name; mount_info.mount_file_reset dst let symlink_file = if Sys.os_type = "Win32" then copy_file else symlink_file_unix let create_node mount_info mounts dir name = match mount_info with {Omake_node_sig.mount_file_exists = file_exists; _ } -> let dir, key, name = new_file dir name in let node = NodeHash.create (NodeFile (dir, key, name)) in let rec search mounts = match mounts with (dir_dst, dir_src, options) :: mounts -> (try let node' = resolve_mount_node dir_dst dir_src node in if file_exists node' then if List.mem Omake_node_sig.MountCopy options then begin copy_file mount_info node' node; node end else if List.mem Omake_node_sig.MountLink options then begin symlink_file mount_info node' node; node end else node' else raise Not_found with Not_found -> search mounts) | [] -> node in search mounts end (* * Intern a string with no escapes. * This version ignores mount points. * Check for existing phonies first. * NOTE: NodeHash.intern will not create the * node if it does not already exist. *) let create_node_or_phony_1 phonies mount_info mount phony_ok dir pname = match pname, phony_ok with | PhonyDirString name, Omake_node_sig.PhonyOK | PhonyDirString name, PhonyExplicit -> let dir, key, name = new_file dir name in NodeHash.create (NodePhonyDir (dir, key, name)) | PhonyGlobalString name, PhonyOK | PhonyGlobalString name, PhonyExplicit -> NodeHash.create (NodePhonyGlobal name) | PhonyDirString _, PhonyProhibited | PhonyGlobalString _, PhonyProhibited -> raise (Invalid_argument "Omake_node.Node.intern: NodePhony is not allowed"); | PhonySimpleString name, PhonyOK -> (* Try PhonyDir first *) let node : NodeElt.t = NodePhonyDir (dir, FileCase.create dir name, name) in if PreNodeSet.mem phonies node then NodeHash.create node else (* Try PhonyGlobal next *) let node : NodeElt.t = NodePhonyGlobal name in if PreNodeSet.mem phonies node then NodeHash.create node else Node.create_node mount_info mount dir name | PhonySimpleString name, PhonyExplicit | PhonySimpleString name, PhonyProhibited | PhonyPathString name, _ -> Node.create_node mount_info mount dir name let node_will_be_phony phonies phony_ok dir pname = (* whether create_node_or_phony will return a phony node (true) or a normal node (false) *) match pname, phony_ok with | PhonyDirString _, _ | PhonyGlobalString _, _ -> true | PhonySimpleString name, Omake_node_sig.PhonyOK -> let node : NodeElt.t = NodePhonyDir (dir, FileCase.create dir name, name) in PreNodeSet.mem phonies node || (* Try PhonyGlobal next *) let node : NodeElt.t = NodePhonyGlobal name in PreNodeSet.mem phonies node | _ -> false let create_node_or_phony phonies mount_info mount phony_ok dir name = create_node_or_phony_1 phonies mount_info mount phony_ok dir (parse_phony_name name) (* * Print the directory, for debugging. *) let pp_print_dir buf dir = let root, _, path = path_of_dir dir in Format.fprintf buf "%s%s" (**) (Lm_filename_util.string_of_root root) (flatten_dir path) (* * Print the kind. *) let pp_print_node_kind buf kind = let s = match kind with Omake_node_sig.NodePhony -> "phony" | NodeOptional -> "optional" | NodeExists -> "exists" | NodeSquashed -> "squashed" | NodeScanner -> "scanner" | NodeNormal -> "normal" in Lm_printf.pp_print_string buf s (* * Print the node, for debugging. *) let pp_print_node buf node = match Node.kind node with NodePhony -> Format.fprintf buf "" (Node.fullname node) | NodeOptional -> Format.fprintf buf "" (Node.fullname node) | NodeExists -> Format.fprintf buf "" (Node.fullname node) | NodeSquashed -> Format.fprintf buf "" (Node.fullname node) | NodeScanner -> Format.fprintf buf "" (Node.fullname node) | NodeNormal -> Lm_printf.pp_print_string buf (Node.fullname node) let pp_print_string_list buf sources = List.iter (fun s -> Format.fprintf buf "@ %s" s) (List.sort String.compare sources) (* let pp_compare_nodes n1 n2 = *) (* let cmp = Pervasives.compare (Node.kind n1) (Node.kind n2) in *) (* if cmp = 0 then *) (* let cmp = String.compare (Node.fullname n1) (Node.fullname n2) in *) (* if cmp = 0 then *) (* NodeHash.compare n1 n2 *) (* else *) (* cmp *) (* else *) (* cmp *) (* let pp_print_node_sorted buf nodes = *) (* let nodes = List.sort pp_compare_nodes nodes in *) (* List.iter (fun node -> Format.fprintf buf "@ %a" pp_print_node node) nodes *) let pp_print_node_list buf nodes = List.iter (fun node -> Format.fprintf buf "@ %a" pp_print_node node) nodes let pp_print_node_set buf set = pp_print_node_list buf (NodeSet.elements set) let pp_print_node_table buf table = pp_print_node_list buf (NodeTable.keys table) let pp_print_node_set_table buf table = NodeTable.iter (fun node set -> Format.fprintf buf "@ @[%a:%a@]" (**) pp_print_node node pp_print_node_set set) table let pp_print_node_set_table_opt buf table_opt = match table_opt with |Some table -> pp_print_node_set_table buf table | None -> Lm_printf.pp_print_string buf "" omake-0.10.3/src/ir/omake_cache.ml0000644000175000017500000015266013177364665015321 0ustar gerdgerd(* * Keep a cache that determines whether we _really_ need to run * a command to build a file. * * The basic idea is this: for each file, remember the command * that built it, its Digest, and the Digest of the files it * depends on. If we want to build the node again, and all * the parts are the same, then we don't actually need to build * it. * * The same principle works for scanners. *) let debug_cache = Lm_debug.create_debug (**) { debug_name = "cache"; debug_description = "Display debugging information for the cache"; debug_value = false } (* * An index table. * The indexes are small enough that (-) is a correct ordering function. *) module IndexCompare = struct type t = int let compare = (-) end module IndexTable = Lm_map.LmMakeList (IndexCompare);; module IndexNodeTable = struct type t = Omake_node.NodeSet.t IndexTable.t let empty = IndexTable.empty let add table i node = IndexTable.filter_add table i (fun nodes -> match nodes with Some nodes -> Omake_node.NodeSet.add nodes node | None -> Omake_node.NodeSet.singleton node) let find = IndexTable.find end;; (* * Directory entry is a directory or node. *) type dir_entry_core = LazyEntryCore of Omake_node.Dir.t * string | DirEntryCore of Omake_cache_type.dir_entry type dir_listing_item = dir_entry_core ref Lm_string_set.StringTable.t type dir_listing = dir_listing_item list (* * Executable listing. *) type exe_entry_core = ExeEntryCore of (Omake_node.Dir.t * string) list | ExeEntryNodes of Omake_node.Node.t list type exe_listing_item = exe_entry_core ref Lm_string_set.StringTable.t type exe_listing = exe_listing_item list type compact_stats = string (* File stats as a single string (only for comparison) *) (* * Stats of a file. * FreshStats: we have taken the stats during this program run * OldStats: we took the stats during a prior run of this program *) (* %%MAGICBEGIN%% *) type node_stats = FreshStats of compact_stats | OldStats of compact_stats (* %%MAGICEND%% *) (* * For each file, we keep the stats and the digest. *) (* %%MAGICBEGIN%% *) type node_memo = { nmemo_stats : node_stats; nmemo_digest : Digest.t option; (* None = not yet computed *) } (* %%MAGICEND%% *) (* * The memo is a record of what we have done during * a previous run of this program. * * The index is a hash over the deps and the commands. * The result is mainly used for the scanner, to return * the results of the previous scan. * * We don't really care what the commands are, we just * care what their digest is. *) (* %%MAGICBEGIN%% *) type 'a memo = { memo_index : int; memo_deps : Omake_node.NodeSet.t; memo_targets_tab : tab_entry Omake_node.NodeTable.t; memo_deps_tab : tab_entry Omake_node.NodeTable.t; memo_commands : Omake_command_type.command_digest; memo_result : 'a Omake_cache_type.memo_result; memo_updated : int; } and tab_entry = (string * Digest.t option) option (* None = node does not exist Some(cstat,None) = node exists, but digest is unknown Some(cstat,Some digest) *) (* %%MAGICEND%% *) (* * The memos are classified by functions. * Each function has a table of memos, and an index. *) type key = int type 'a cache_info = { mutable cache_memos : 'a memo Omake_node.NodeTable.t; mutable cache_index : IndexNodeTable.t } (* * The cache remembers all the build commands we did last time. *) type stat = Unix.LargeFile.stats type cache = { (* State *) mutable cache_nodes : node_memo Omake_node.NodeTable.t; mutable cache_exists : bool Omake_node.NodeTable.t; mutable cache_exists_num : int; mutable cache_exists_lru : Omake_node.Node.t list; mutable cache_info : Omake_cache_type.memo_deps cache_info array; mutable cache_static_values : Omake_value_type.obj memo Omake_value_util.ValueTable.t; mutable cache_memo_values : Omake_value_type.obj memo Omake_value_util.ValueTable.t; mutable cache_file_stat_count : int; (* only succeessful stats are counted *) mutable cache_digest_count : int; (* Path lookups *) mutable cache_dirs : (stat option * dir_listing_item) Omake_node.DirTable.t; mutable cache_path : (stat option list * dir_listing_item) Omake_node.DirListTable.t; mutable cache_exe_path : (stat option list * exe_listing_item) Omake_node.DirListTable.t; (* Delayed updates *) mutable cache_info_delayed : (key * Omake_node.Node.t) Queue.t; (* Updates of memos increase the cache_time *) mutable cache_time : int; } (* * The version of the cache that is saved in the file also * contains a table of all nodes. *) (* %%MAGICBEGIN%% *) type cache_save = { save_cache_nodes : node_memo Omake_node.NodeTable.t; save_cache_info : Omake_cache_type.memo_deps memo Omake_node.NodeTable.t array; save_cache_value : Omake_value_type.obj memo Omake_value_util.ValueTable.t; save_cache_time : int; } (* %%MAGICEND%% *) (* * Squash stat code. (Returned for directories, non-regular files, and nodes * where contents do not matter.) *) let squash_stat = "squash" (* * The cache type. *) type t = cache (* * Memo functions for the cache. *) let scanner_fun = 0 let rule_fun = 1 let env_fun = 2 let include_fun = 3 let env_target = Omake_node.Node.create_phony_global ".ENV" (************************************************************************ * Printing. *) (* * Print a digest. *) let pp_print_digest buf digest = let s = match digest with Some(cstats,digest) -> "<" ^ cstats ^ "/" ^ Lm_string_util.hexify digest ^ ">" | None -> "" in Lm_printf.pp_print_string buf s (* * Print a digest table. *) let pp_print_node_digest_table buf deps = Omake_node.NodeTable.iter (fun node digest -> Format.fprintf buf "@ %a = %a" (**) Omake_node.pp_print_node node pp_print_digest digest) deps (* * Print a result. *) let pp_print_memo_result _pp_print_result buf result = match result with Omake_cache_type.MemoSuccess _ -> Format.fprintf buf "@ success" | MemoFailure code -> Format.fprintf buf "@ failed(%d)" code let name_of node = let buf = Buffer.create 80 in let formatter = Format.formatter_of_buffer buf in Omake_node.pp_print_node formatter node; Format.pp_print_flush formatter(); Buffer.contents buf let string_of_cmdhash = function | None -> "n/a" | Some dg -> Lm_string_util.hexify dg (* * Print a memo. *) (* let pp_print_memo buf memo = *) (* let { memo_index = index; *) (* memo_targets = targets; *) (* memo_deps = deps; *) (* memo_result = _result; *) (* memo_commands = commands *) (* } = memo *) (* in *) (* Format.fprintf buf "@[@[memo {@ index = %d;@ @[targets =%a@];@ @[deps =%a@]@ @[commands =%a@]@]@ }@]" (\**\) *) (* index *) (* pp_print_node_digest_table targets *) (* pp_print_node_digest_table deps *) (* pp_print_digest commands *) (************************************************************************ * Persistence. *) (* * Create the cache. We save the cache in a file, so try to * load it from that file. *) let magic_number = Omake_magic.cache_magic let input_magic = Omake_magic.input_magic let output_magic = Omake_magic.output_magic (* * Create a new cache. *) let create () = { cache_nodes = Omake_node.NodeTable.empty; cache_exists = Omake_node.NodeTable.empty; cache_exists_num = 0; cache_exists_lru = []; cache_info = [||]; cache_static_values = Omake_value_util.ValueTable.empty; cache_memo_values = Omake_value_util.ValueTable.empty; cache_file_stat_count = 0; cache_digest_count = 0; cache_dirs = Omake_node.DirTable.empty; cache_path = Omake_node.DirListTable.empty; cache_exe_path = Omake_node.DirListTable.empty; cache_info_delayed = Queue.create(); cache_time = 0; } let rehash cache = cache.cache_dirs <- Omake_node.DirTable.empty; cache.cache_path <- Omake_node.DirListTable.empty; cache.cache_exe_path <- Omake_node.DirListTable.empty let stats { cache_file_stat_count = stat_count; cache_digest_count = digest_count; _ } = stat_count, digest_count (* * When the file is saved, remove all stat information, * as well as any files that don't exist. *) let save_of_cache cache = let { cache_nodes = cache_nodes; cache_info = cache_info; cache_static_values = cache_values; _ } = cache in let cache_nodes = Omake_node.NodeTable.fold (fun nodes target nmemo -> match nmemo.nmemo_stats with FreshStats stats | OldStats stats -> let nmemo = { nmemo with nmemo_stats = OldStats stats } in Omake_node.NodeTable.add nodes target nmemo ) Omake_node.NodeTable.empty cache_nodes in let cache_info = Array.map (fun info -> info.cache_memos) cache_info in { save_cache_nodes = cache_nodes; save_cache_info = cache_info; save_cache_value = cache_values; save_cache_time = cache.cache_time } (* * Rebuild the index from the memos. *) let create_index memos = Omake_node.NodeTable.fold (fun (memos, index) target memo -> let { memo_result = result; memo_index = hash; _ } = memo in match result with Omake_cache_type.MemoSuccess _ -> let index = IndexNodeTable.add index hash target in memos, index | MemoFailure _ -> let memos = Omake_node.NodeTable.remove memos target in memos, index) (memos, IndexNodeTable.empty) memos (* * Rebuild the cache from the saved version. *) let cache_of_save options save = let { save_cache_nodes = cache_nodes; save_cache_info = cache_info; _ } = save in let flush_scanner = Omake_options.opt_flush_dependencies options in let cache_info = Array.mapi (fun idx memos -> if flush_scanner && idx = scanner_fun then { cache_memos = Omake_node.NodeTable.empty; cache_index = IndexNodeTable.empty } else let memos, index = create_index memos in { cache_memos = memos; cache_index = index }) cache_info in let cache_values = if Omake_options.opt_flush_static options then Omake_value_util.ValueTable.empty else save.save_cache_value in { (create ()) with cache_nodes = cache_nodes; cache_info = cache_info; cache_static_values = cache_values; cache_time = save.save_cache_time; } (* * Load the old cache from a file. *) let from_channel options inx = if Lm_debug.debug debug_cache then Format.eprintf "Loading cache@."; if Omake_options.opt_flush_cache options then create () else let magic = input_magic inx in let _ = if magic <> magic_number then raise (Sys_error "bad magic number") in let save = Marshal.from_channel inx in cache_of_save options save (* * Save the cache to the file. *) let to_channel outx cache = if Lm_debug.debug debug_cache then Format.eprintf "Saving cache@."; output_magic outx magic_number; Marshal.to_channel outx (save_of_cache cache) [] (************************************************************************ * File existence. *) (* Caching the existence of files seems to have a good performance effect on Windows. There is no benefit on Linux. We try to keep the size of the cache small (fast lookups, no waste of RAM), as the locality of the accesses is high. NB. In older omake versions there was even a cache for stat records. We don't need this the complete records for regular builds, though. Only the file existence is important. *) let ex_limit = 100 (* we start a GC pass at 2*ex_limit and keep only ex_limit entries (lru) *) let ex_query cache node = let ex_flag = Omake_node.NodeTable.find cache.cache_exists node in cache.cache_exists_lru <- node :: cache.cache_exists_lru; ex_flag exception Ex_result of bool Omake_node.NodeTable.t * int let ex_collect cache = let old = cache.cache_exists in let ex, num = try List.fold_left (fun (ex,num) node -> try if num >= ex_limit then raise(Ex_result(ex,num)) else if not (Omake_node.NodeTable.mem ex node) then let ex_flag = Omake_node.NodeTable.find old node in (Omake_node.NodeTable.add ex node ex_flag, num+1) else (ex,num) with Not_found -> (ex,num) ) (Omake_node.NodeTable.empty, 0) cache.cache_exists_lru with | Ex_result(ex,num) -> (ex,num) in cache.cache_exists <- ex; cache.cache_exists_num <- num; cache.cache_exists_lru <- [] let ex_set cache node ex_flag = if Lm_debug.debug debug_cache then Format.eprintf "Caching existence: ex_set(%s,%B)@." (name_of node) ex_flag; cache.cache_exists_lru <- node :: cache.cache_exists_lru; try let old_flag = Omake_node.NodeTable.find cache.cache_exists node in if ex_flag <> old_flag then cache.cache_exists <- Omake_node.NodeTable.add cache.cache_exists node ex_flag with | Not_found -> cache.cache_exists <- Omake_node.NodeTable.add cache.cache_exists node ex_flag; cache.cache_exists_num <- cache.cache_exists_num + 1; if cache.cache_exists_num > 2*ex_limit then ex_collect cache let ex_reset cache node = if Lm_debug.debug debug_cache then Format.eprintf "Resetting existence: ex_reset(%s)@." (name_of node); cache.cache_exists <- Omake_node.NodeTable.remove cache.cache_exists node (* we don't update cache_exists_num, which is only an upper bound *) (************************************************************************ * Stat. *) (* * Reset the information about a node (probably because * we ran a command that changed it). *) let reset cache node = if Lm_debug.debug debug_cache then Format.eprintf "Oldifying stats: reset(%s)@." (name_of node); let nodes = cache.cache_nodes in let nodes = try Omake_node.NodeTable.filter_remove nodes node (fun nmemo -> match nmemo.nmemo_stats with FreshStats stats | OldStats stats -> Some { nmemo with nmemo_stats = OldStats stats }) with Not_found -> nodes in cache.cache_nodes <- nodes; ex_reset cache node let reset_set cache nodes = Omake_node.NodeSet.iter (reset cache) nodes let reset_table cache nodes = Omake_node.NodeTable.iter (fun node _ -> reset cache node) nodes let compact_stats s = let open Unix.LargeFile in Printf.sprintf "%x:%x:%Lx:%Lx" s.st_dev s.st_ino s.st_size (Int64.bits_of_float s.st_mtime) (* * Test whether stats are equal enough that we think the * file is up-to-date. *) let stats_equal stat1 stat2 = stat1 = stat2 (* let pp_print_stat buf (stat : Unix.LargeFile.stats) = *) (* match stat with *) (* { st_ino = ino; *) (* st_kind = _kind; *) (* st_size = size; *) (* st_mtime = mtime; *) (* _ *) (* } -> *) (* Format.fprintf buf "ino = %d, size = %Ld, mtime = %g" ino size mtime *) let digest_file name _file_size = Digest.file name let stat_file_update_digest ?old cache node = let nodes = cache.cache_nodes in let name = Omake_node.Node.fullname node in ( try let stats = Unix.LargeFile.stat name in let cstats = compact_stats stats in ex_set cache node true; if stats.Unix.LargeFile.st_kind <> Unix.S_REG then ( if Lm_debug.debug debug_cache then Format.eprintf "Removing stats (type change): \ stat_file_update_digest(%s)@." (name_of node); cache.cache_nodes <- Omake_node.NodeTable.remove nodes node; Some (cstats, squash_stat) ) else ( cache.cache_file_stat_count <- succ cache.cache_file_stat_count; let digest = (* Old: do a conditional update of the digest *) match old with | Some ({ nmemo_digest = Some digest; _ },cstats') when stats_equal cstats cstats' -> if Lm_debug.debug debug_cache then Format.eprintf "Keeping stats and digest: \ stat_file_update_digest(%s) dg=%s@." (name_of node) (Lm_string_util.hexify digest); digest | _ -> let digest = digest_file name stats.Unix.LargeFile.st_size in if Lm_debug.debug debug_cache then Format.eprintf "Renewing stats and digest: \ stat_file_update_digest(%s) dg=%s@." (name_of node) (Lm_string_util.hexify digest); cache.cache_digest_count <- succ cache.cache_digest_count; digest in let nmemo = { nmemo_stats = FreshStats cstats; nmemo_digest = Some digest } in cache.cache_nodes <- Omake_node.NodeTable.add nodes node nmemo; Some (cstats, digest) ) with | Unix.Unix_error _ | Sys_error _ -> if Lm_debug.debug debug_cache then Format.eprintf "Removing stats (lookup error): \ stat_file_update_digest(%s)@." (name_of node); cache.cache_nodes <- Omake_node.NodeTable.remove nodes node; ex_set cache node false; None ) (* * Stat a file. (Returns compact_stat * digest.) *) let stat_file cache node = let nodes = cache.cache_nodes in let old_nmemo = try Some (Omake_node.NodeTable.find nodes node) with Not_found -> None in match old_nmemo with | Some { nmemo_stats = FreshStats cstats; nmemo_digest = Some digest } -> (* We've recently computed the digest for this file. *) Some(cstats, digest) | Some { nmemo_stats = FreshStats _; nmemo_digest = None } -> (* The stats are recent, but no digest yet. So do a full update *) stat_file_update_digest cache node | Some ({ nmemo_stats = OldStats cstats ; _} as nmemo) -> (* We have no recent record of this file. Get current stats. If they match, then use current digest; otherwise recompute. *) stat_file_update_digest ~old:(nmemo, cstats) cache node | None -> (* We've never seen this file before. Get complete stats, including a digest. *) stat_file_update_digest cache node let compact_stat_file cache node = (* get only compact_stat *) let nodes = cache.cache_nodes in let name = Omake_node.Node.fullname node in let old_nmemo = try Some (Omake_node.NodeTable.find nodes node) with Not_found -> None in match old_nmemo with | Some { nmemo_stats = FreshStats cstats; _ } -> if Lm_debug.debug debug_cache then Format.eprintf "Keeping stats: \ compact_stat_file(%s)@." (name_of node); Some cstats | _ -> ( try let stats = Unix.LargeFile.stat name in let cstats = compact_stats stats in ex_set cache node true; if stats.Unix.LargeFile.st_kind <> Unix.S_REG then ( if Lm_debug.debug debug_cache then Format.eprintf "Removing stats (type change): \ compact_stat_file(%s)@." (name_of node); cache.cache_nodes <- Omake_node.NodeTable.remove nodes node ) else ( let old_digest = match old_nmemo with | Some ({ nmemo_stats = OldStats ocstats ; _} as nmemo) -> if ocstats = cstats then ( if Lm_debug.debug debug_cache then Format.eprintf "Keeping stats and digest: \ compact_stat_file(%s)@." (name_of node); nmemo.nmemo_digest ) else ( if Lm_debug.debug debug_cache then Format.eprintf "Renewing stats and removing digest: \ compact_stat_file(%s)@." (name_of node); None ) | _ -> None in let nmemo = { nmemo_stats = FreshStats cstats; nmemo_digest = old_digest; } in cache.cache_nodes <- Omake_node.NodeTable.add nodes node nmemo; ); Some cstats with | Unix.Unix_error _ | Sys_error _ -> if Lm_debug.debug debug_cache then Format.eprintf "Removing stats (lookup error): \ compact_stat_file(%s)@." (name_of node); cache.cache_nodes <- Omake_node.NodeTable.remove nodes node; ex_set cache node false; None ) let has_file_stat_1 ?compact_stat ?digest cache node : bool option = (* Check whether a file has certain stats: - [compact_stat]: if passed, checks whether the file exists and has these stats - [digest]: if passed, checks whether the file exists and has this digest Returns None if the file does not exist. Otherwise [Some b], and [b] says whether the above criteria are fulfilled. *) let st_check cstats = match compact_stat with | Some c -> stats_equal c cstats | None -> true in let check cstats dg_opt = try Some ( st_check cstats && match digest, dg_opt with | (Some d1, Some d2) -> d1 = d2 | (Some d1, None) -> ( match stat_file cache node with | Some(cstats1, dg) -> st_check cstats1 && d1 = dg | None -> raise Not_found ) | (None, _) -> true ) with Not_found -> None in let nodes = cache.cache_nodes in let old_nmemo = try Some (Omake_node.NodeTable.find nodes node) with Not_found -> None in match old_nmemo with | Some { nmemo_stats = FreshStats cstats; nmemo_digest = Some digest } -> check cstats (Some digest) | Some { nmemo_stats = FreshStats cstats; nmemo_digest = None } -> check cstats None | _ -> if digest = None then match compact_stat_file cache node with | None -> None | Some cstats -> check cstats None else match stat_file cache node with | None -> None | Some(cstats,dg) -> check cstats (Some dg) let has_file_stat ?compact_stat ?digest cache node = if Lm_debug.debug debug_cache then ( let result = has_file_stat_1 ?compact_stat ?digest cache node in Format.eprintf "has_file_stat(%s,compact=%s,digest=%s) = %s@." (name_of node) (match compact_stat with | None -> "n/a" | Some cstat -> cstat ) (string_of_cmdhash digest) (match result with | None -> "None" | Some b -> string_of_bool b ); result ) else has_file_stat_1 ?compact_stat ?digest cache node let stat_unix_node cache ~force node = (* We used to cache this information, but don't do this anymore. Hence, the [force] flag is ignored: we always re-stat *) ignore(force); let name = Omake_node.Node.fullname node in try let s = Unix.LargeFile.stat name in ex_set cache node true; s with Unix.Unix_error _ | Sys_error _ -> ex_set cache node false; raise Not_found (* * lstat versions, for not following symlinks. *) let lstat_unix_node _cache ~force node = (* We used to cache this information, but don't do this anymore. Hence, the [force] flag is ignored: we always re-stat *) ignore(force); let name = Omake_node.Node.fullname node in try Unix.LargeFile.lstat name with Unix.Unix_error _ | Sys_error _ -> raise Not_found (* * Cached stat. *) let stat_unix cache ?(force=false) ?(follow_symlinks=true) node = let node = match Omake_node.Node.kind node with NodePhony | NodeScanner -> raise Not_found | NodeNormal -> node | NodeOptional | NodeSquashed | NodeExists -> Omake_node.Node.core node in if follow_symlinks then stat_unix_node cache ~force node else lstat_unix_node cache ~force node (* * Check if a file is a directory. *) let is_dir cache ?(force=false) ?(follow_symlinks=true) node = try (stat_unix cache ~force ~follow_symlinks node).Unix.LargeFile.st_kind = Unix.S_DIR with Not_found -> false (* * Tests for whether a file is executable. * This really only works on Unix. *) let euid = try Unix.geteuid () with Unix.Unix_error _ -> 0 let groups = try Array.to_list (Unix.getgroups ()) with Unix.Unix_error _ -> [] (* * Check if the node is phony first. *) let stat cache node = (* Printf.eprintf "stat node=%s\n%!" (name_of node); *) let core = Omake_node.Node.core node in match Omake_node.Node.kind node with NodePhony | NodeScanner -> None | NodeOptional | NodeNormal -> stat_file cache core | NodeSquashed | NodeExists -> (match stat_file cache core with | Some(cstats,_) -> Some(cstats,squash_stat) | None -> None ) let has_stat ?compact_stat ?digest cache node : bool option = let core = Omake_node.Node.core node in match Omake_node.Node.kind node with NodePhony | NodeScanner -> None | NodeOptional | NodeNormal -> has_file_stat ?compact_stat ?digest cache core | NodeSquashed | NodeExists -> (match stat_file cache core with | Some _ -> Some true | None -> None ) let compact_stat cache node = let core = Omake_node.Node.core node in match Omake_node.Node.kind node with NodePhony | NodeScanner -> None | NodeOptional | NodeNormal | NodeSquashed | NodeExists -> compact_stat_file cache core (* * Turn a set into a table of stat info. *) let stat_set cache nodes = Omake_node.NodeSet.fold (fun table node -> Omake_node.NodeTable.add table node (stat cache node)) Omake_node.NodeTable.empty nodes let stat_set_for_add ?(compact=false) cache nodes = Omake_node.NodeSet.fold (fun table node -> let out = if compact then match compact_stat cache node with | None -> None | Some cstat -> Some (cstat, None) else match stat cache node with | None -> None | Some(cstat,dg) -> Some (cstat, Some dg) in Omake_node.NodeTable.add table node out) Omake_node.NodeTable.empty nodes let complement_stat_set_for_add cache node_tab = Omake_node.NodeTable.mapi (fun node info_opt -> match info_opt with | None -> None | Some(cstat, None) -> ( match stat cache node with | None -> info_opt (* "None" would be surprising *) | Some(cstat_new, digest) -> if cstat = cstat_new then Some(cstat, Some digest) else info_opt (* be conservative here *) ) | Some(_, Some _) -> info_opt ) node_tab let stat_table cache nodes = Omake_node.NodeTable.mapi (fun node _ -> stat cache node) nodes (* * Force a stat. *) let force_stat cache node = reset cache node; stat cache node let force_stat_set cache nodes = Omake_node.NodeSet.fold (fun table node -> Omake_node.NodeTable.add table node (force_stat cache node)) Omake_node.NodeTable.empty nodes let force_stat_table cache nodes = Omake_node.NodeTable.mapi (fun node _ -> force_stat cache node) nodes (* * Check if the stat changed. *) let stat_changed cache node = let old_digest = try (Omake_node.NodeTable.find cache.cache_nodes node).nmemo_digest with Not_found -> None in match force_stat cache node with | Some(_, dg) -> old_digest <> Some dg | None -> old_digest <> None (* * Check if a file exists. *) let exists cache ?(force=false) node = try if force then raise Not_found; ex_query cache node with | Not_found -> try ignore (stat_unix cache ~force node); true with Not_found -> Omake_node.Node.always_exists node let exists_dir cache ?(force=false) dir = exists cache ~force (Omake_node.Node.node_of_dir dir) (************************************************************************ * Adding to the cache. *) (* * Hash a set of deps and commands. * The commands is a digest. *) let hash_index deps commands = let index = Omake_node.NodeSet.fold (fun index node -> index lxor (index lsl 4) lxor (index lsr 4) lxor (Omake_node.Node.hash node)) 0 deps in let index = index lxor (index lsl 4) lxor (index lsr 4) lxor (Hashtbl.hash commands) in index land 0x3fffffff (* * Expand the cache_info if necessary. *) let get_info cache key = let cache_info = cache.cache_info in let len = Array.length cache_info in let cache_info = if key >= Array.length cache_info then begin let cache_info' = Array.init (succ key) (fun _ -> { cache_memos = Omake_node.NodeTable.empty; cache_index = IndexNodeTable.empty }) in Array.blit cache_info 0 cache_info' 0 len; cache.cache_info <- cache_info'; cache_info' end else cache_info in cache_info.(key) (* * Add a command. *) let add cache key target targets deps commands result = if Lm_debug.debug debug_cache then Format.eprintf "Adding rule digests: add(key:%d,target:%s)@." key (name_of target); let index = hash_index deps commands in let memo = { memo_index = index; memo_deps = deps; memo_targets_tab = stat_set_for_add ~compact:true cache targets; memo_deps_tab = stat_set_for_add ~compact:true cache deps; memo_result = result; memo_commands = commands; memo_updated = cache.cache_time } in let info = get_info cache key in info.cache_memos <- Omake_node.NodeTable.add info.cache_memos target memo; info.cache_index <- IndexNodeTable.add info.cache_index index target; cache.cache_time <- cache.cache_time + 1; (* schedule to add the digests later: *) Queue.add (key, target) cache.cache_info_delayed let is_digest_missing node_tab = Omake_node.NodeTable.exists (fun _ info_opt -> match info_opt with | Some(_, None) -> true | _ -> false ) node_tab let add_digests cache key target = try let info = get_info cache key in let memo = Omake_node.NodeTable.find info.cache_memos target in let p1 = is_digest_missing memo.memo_targets_tab in let p2 = is_digest_missing memo.memo_deps_tab in if p1 || p2 then ( if Lm_debug.debug debug_cache then Format.eprintf "Updating rule digests: add_digests(key:%d,target:%s)@." key (name_of target); let memo' = { memo with memo_targets_tab = (if p1 then complement_stat_set_for_add cache memo.memo_targets_tab else memo.memo_targets_tab); memo_deps_tab = (if p1 then complement_stat_set_for_add cache memo.memo_deps_tab else memo.memo_deps_tab); memo_updated = cache.cache_time } in info.cache_memos <- Omake_node.NodeTable.add info.cache_memos target memo'; cache.cache_time <- cache.cache_time + 1; ) with | Not_found -> () (* * Check the target digest. *) let targets_equal_1 cache targets_tab = (* A quick check only using Unix.stat. Not_found if files are missing *) Omake_node.NodeTable.forall (fun target old_stat -> match old_stat with | Some (cstats, _) -> ( match has_stat ~compact_stat:cstats cache target with | Some b -> b | None -> raise Not_found (* target does not exist *) ) | None -> (* the recorded target did not exist as file *) has_stat cache target = None ) targets_tab let targets_equal_2 cache targets_tab = (* A deep check using digests (if available) *) Omake_node.NodeTable.forall (fun target old_stat -> match old_stat with | Some (_, Some digest) -> has_stat ~digest cache target = Some true | Some (cstats, None) -> has_stat ~compact_stat:cstats cache target = Some true | None -> (* the recorded target did not exist as file *) has_stat cache target = None ) targets_tab let targets_equal cache targets_tab = try targets_equal_1 cache targets_tab || targets_equal_2 cache targets_tab with | Not_found -> false (* * Check if deps are the same. * This returns true if the deps are equal (deps: the nodes as of now; * deps_tab: the recorded properties from the last run). * If not, it either returns false, or raises Not_found. *) let deps_equal_1 cache deps deps_tab = (* A quick check only using Unix.stat. Not_found if files are missing *) let count1 = Omake_node.NodeSet.cardinal deps in let count2 = Omake_node.NodeTable.cardinal deps_tab in (count1 = count2) && Omake_node.NodeSet.for_all (fun dep -> match Omake_node.NodeTable.find deps_tab dep with | Some(cstats,_) -> ( match has_stat ~compact_stat:cstats cache dep with | None -> raise Not_found | Some ok -> ok ) | None -> (* the recorded dep did not exist as file *) has_stat cache dep = None ) deps let deps_equal_2 cache deps deps_tab = (* A deep check using digests (if available) *) let count1 = Omake_node.NodeSet.cardinal deps in let count2 = Omake_node.NodeTable.cardinal deps_tab in (count1 = count2) && Omake_node.NodeSet.for_all (fun dep -> match Omake_node.NodeTable.find deps_tab dep with | Some (_, Some digest) -> has_stat ~digest cache dep = Some true | Some (cstats, None) -> has_stat ~compact_stat:cstats cache dep = Some true | None -> (* the recorded dep did not exist as file *) has_stat cache dep = None ) deps let deps_equal cache deps deps_tab = try deps_equal_1 cache deps deps_tab || deps_equal_2 cache deps deps_tab with | Not_found -> false (* * Find a memo from the deps and commands. Note that there can be several * memos for a pair (deps,commands) when the rule has several effects. In * that case we return the most recently updated version. *) let find_memo cache key deps commands = let { cache_memos = memos; cache_index = index } = get_info cache key in let hash = hash_index deps commands in let rec search best_time best targets = match targets with | target :: targets -> let memo = Omake_node.NodeTable.find memos target in let { memo_index = hash'; memo_deps = deps'; memo_commands = commands'; memo_updated = time; _ } = memo in if time > best_time && hash' = hash && commands = commands' && Omake_node.NodeSet.equal deps deps' then search time (Some memo) targets else search best_time best targets | [] -> ( match best with | None -> raise Not_found | Some memo -> memo ) in let targets = Omake_node.NodeSet.to_list (IndexNodeTable.find index hash) in search (-1) None targets (* * A memo has not changed if all the deps and the target * have the same digests. *) let up_to_date cache key deps commands = try let memo = find_memo cache key deps commands in if targets_equal cache memo.memo_targets_tab && deps_equal cache deps memo.memo_deps_tab then match memo.memo_result with MemoSuccess _ -> true | MemoFailure _ -> false else false with Not_found -> false let up_to_date_status cache key deps commands = try let memo = find_memo cache key deps commands in let p1 = targets_equal cache memo.memo_targets_tab in let p2 = lazy(deps_equal cache deps memo.memo_deps_tab) in if Lm_debug.debug debug_cache then Format.eprintf "up_to_date_status(cmdhash=%s): \ targets_equal=%B deps_equal=%B" (string_of_cmdhash commands) p1 (Lazy.force p2); if p1 && Lazy.force p2 then ( match memo.memo_result with | Omake_cache_type.MemoSuccess _ -> if Lm_debug.debug debug_cache then Format.eprintf " status=StatusSuccess@."; Omake_cache_type.StatusSuccess | MemoFailure code -> if Lm_debug.debug debug_cache then Format.eprintf " status=StatusFailure@."; StatusFailure code ) else ( if Lm_debug.debug debug_cache then Format.eprintf " status=StatusUnknown@."; StatusUnknown ) with Not_found -> if Lm_debug.debug debug_cache then Format.eprintf " status=StatusUnknown (Not_found)@."; StatusUnknown (* * A memo has not changed if all the deps and the target * have the same digests. *) let target_results results = match results with Omake_cache_type.MemoFailure _ -> raise Not_found | MemoSuccess deps -> deps let find_result cache key deps commands = let memo = find_memo cache key deps commands in let { memo_targets_tab = targets_tab; memo_deps_tab = deps_tab; memo_result = result; _ } = memo in if targets_equal cache targets_tab && deps_equal cache deps deps_tab then target_results result else raise Not_found (* * Find the result of a run, without the commands. *) let find_result_sloppy cache key target = let { cache_memos = memos ; _} = get_info cache key in let memo = Omake_node.NodeTable.find memos target in match memo.memo_result with MemoFailure _ -> raise Not_found | MemoSuccess deps -> deps (************************************************************************ * Delayed stat requests *) let process_delayed_digests cache = if Lm_debug.debug debug_cache then Format.eprintf "Delayed stats: @."; ( try while true do let (key, target) = Queue.take cache.cache_info_delayed in add_digests cache key target done with | Queue.Empty -> () ); if Lm_debug.debug debug_cache then Format.eprintf "Delayed stats: @." (************************************************************************ * Values. In this case, we use the key to find the memo. *) (* * Get the memo entry from the key. *) let get_value cache key is_static = Omake_value_util.ValueTable.find (if is_static then cache.cache_static_values else cache.cache_memo_values) key (* * Find a memo from the deps and commands. *) let find_value_memo cache key is_static deps1 commands1 = let memo = get_value cache key is_static in let hash1 = hash_index deps1 commands1 in let { memo_index = hash2; memo_deps = deps2; memo_commands = commands2; _ } = memo in if hash1 = hash2 && commands1 = commands2 && Omake_node.NodeSet.equal deps1 deps2 then memo else raise Not_found let find_value cache key is_static deps commands = let memo = find_value_memo cache key is_static deps commands in let { memo_targets_tab = targets_tab; memo_deps_tab = deps_tab; memo_result = result; _ } = memo in if targets_equal cache targets_tab && deps_equal cache deps deps_tab then target_results result else raise Not_found let add_value cache key is_static deps commands result = let index = hash_index deps commands in let memo = { memo_index = index; memo_deps = deps; memo_targets_tab = Omake_node.NodeTable.empty; memo_deps_tab = stat_set_for_add ~compact:false cache deps; memo_result = result; memo_commands = commands; memo_updated = cache.cache_time } in cache.cache_time <- cache.cache_time + 1; if is_static then cache.cache_static_values <- Omake_value_util.ValueTable.add cache.cache_static_values key memo else cache.cache_memo_values <- Omake_value_util.ValueTable.add cache.cache_memo_values key memo (************************************************************************ * Directory listings. *) (* * When auto-rehash is in effect, we need to stat the directories * on every lookup. *) let stat_dir cache dir = let name = Omake_node.Dir.fullname dir in try let stat = Unix.LargeFile.stat name in cache.cache_file_stat_count <- succ cache.cache_file_stat_count; Some stat with Unix.Unix_error _ -> None let stat_dirs cache dirs = List.map (stat_dir cache) dirs let stats_equal_opt stat1 stat2 = match stat1, stat2 with Some stat1, Some stat2 -> stats_equal stat1 stat2 | None, None -> true | None, Some _ | Some _, None -> false let rec stats_equal_opt_list stats1 stats2 = match stats1, stats2 with stat1 :: stats1, stat2 :: stats2 -> stats_equal_opt stat1 stat2 && stats_equal_opt_list stats1 stats2 | [], [] -> true | _ :: _, [] | [], _ :: _ -> false let check_stat auto_rehash (stat_old, entries) stat_new = if auto_rehash && not (stats_equal_opt stat_old (Lazy.force stat_new)) then raise Not_found else entries let check_stats auto_rehash (stats_old, entries) stats_new = if auto_rehash && not (stats_equal_opt_list stats_old (Lazy.force stats_new)) then raise Not_found else entries (* * List a directory. *) let list_directory _cache dir = let dirx = try Unix.opendir (Omake_node.Dir.fullname dir) with Unix.Unix_error _ -> raise Not_found in let rec list entries = let name = try Some (Unix.readdir dirx) with Unix.Unix_error _ | End_of_file -> None in match name with Some "." | Some ".." -> list entries | Some name -> let entry = ref (LazyEntryCore (dir, name)) in let entries = Lm_string_set.StringTable.add entries name entry in list entries | None -> entries in let entries = list Lm_string_set.StringTable.empty in Unix.closedir dirx; entries (* * Get the directory listing as a Lm_string_set.StringTable. *) let ls_dir cache auto_rehash dir = let stat = lazy (stat_dir cache dir) in try check_stat auto_rehash (Omake_node.DirTable.find cache.cache_dirs dir) stat with Not_found -> let entries = list_directory cache dir in let stat = Lazy.force stat in cache.cache_dirs <- Omake_node.DirTable.add cache.cache_dirs dir (stat, entries); entries (* * Path version. *) let ls_path cache auto_rehash dirs = let key = Omake_node.DirListHash.create dirs in let stats = lazy (stat_dirs cache dirs) in try check_stats auto_rehash (Omake_node.DirListTable.find cache.cache_path key) stats with Not_found -> (* Fold together the tables *) let stats = Lazy.force stats in let entries = List.fold_left (fun entries1 dir -> try let entries2 = ls_dir cache auto_rehash dir in Lm_string_set.StringTable.fold Lm_string_set.StringTable.add entries1 entries2 with Not_found -> entries1) Lm_string_set.StringTable.empty (List.rev dirs) in cache.cache_path <- Omake_node.DirListTable.add cache.cache_path key (stats, entries); entries (* * Resolve an entry in the listing. *) let listing_find_item cache listing s = let entry_ref = Lm_string_set.StringTable.find listing s in match !entry_ref with DirEntryCore entry -> entry | LazyEntryCore (dir, s) -> let node = Omake_node.Node.create_node Omake_node.no_mount_info Omake_node.Mount.empty dir s in let entry = if is_dir cache node then Omake_cache_type.DirEntry (Omake_node.Dir.chdir dir s) else NodeEntry node in entry_ref := DirEntryCore entry; entry (* * The execution path is a little harder, and it is quite different * on Win32 and Unix. * * On Win32: * - File permission doesn't matter * - Files without suffix, and with .com, .exe, .bat and .cmd suffixes are executable * * On Cygwin: * - Files without suffix must be executable * - Files with .com, .exe, .bat and .cmd suffixes are executable * * On Unix: * - There is no .exe suffix * - Only files that are executable count *) let win32_suffixes = [".com"; ".exe"; ".bat"; ".cmd"] let ls_exe_path_win32 cache auto_rehash dirs = let key = Omake_node.DirListHash.create dirs in let stats = lazy (stat_dirs cache dirs) in try check_stats auto_rehash (Omake_node.DirListTable.find cache.cache_exe_path key) stats with Not_found -> let entries = List.fold_left (fun entries1 dir -> try let entries2 = ls_dir cache auto_rehash dir in Lm_string_set.StringTable.fold (fun entries name _ -> let info = dir, name in let name = String.lowercase_ascii name in let entries = Lm_string_set.StringMTable.add entries name info in if List.exists (Filename.check_suffix name) win32_suffixes then let name = Filename.chop_extension name in Lm_string_set.StringMTable.add entries name info else entries) entries1 entries2 with Not_found -> entries1) Lm_string_set.StringMTable.empty (List.rev dirs) in let entries = Lm_string_set.StringMTable.fold_all (fun entries name info -> Lm_string_set.StringTable.add entries name (ref (ExeEntryCore info))) Lm_string_set.StringTable.empty entries in let stats = Lazy.force stats in cache.cache_exe_path <- Omake_node.DirListTable.add cache.cache_exe_path key (stats, entries); entries let ls_exe_path_unix cache auto_rehash dirs = let key = Omake_node.DirListHash.create dirs in let stats = lazy (stat_dirs cache dirs) in try check_stats auto_rehash (Omake_node.DirListTable.find cache.cache_exe_path key) stats with Not_found -> let entries = List.fold_left (fun entries1 dir -> try let entries2 = ls_dir cache auto_rehash dir in Lm_string_set.StringTable.fold (fun entries name _ -> Lm_string_set.StringMTable.add entries name (dir, name)) entries1 entries2 with Not_found -> entries1) Lm_string_set.StringMTable.empty (List.rev dirs) in let entries = Lm_string_set.StringMTable.fold_all (fun entries name info -> Lm_string_set.StringTable.add entries name (ref (ExeEntryCore info))) Lm_string_set.StringTable.empty entries in let stats = Lazy.force stats in cache.cache_exe_path <- Omake_node.DirListTable.add cache.cache_exe_path key (stats, entries); entries (* * Find the first entry that is executable. *) let is_exe_file cache node = try let { Unix.LargeFile.st_kind = kind; Unix.LargeFile.st_perm = perm; Unix.LargeFile.st_uid = uid; Unix.LargeFile.st_gid = gid; _ } = stat_unix cache node in (kind = Unix.S_REG) && ((perm land 0o001) <> 0 || (List.mem gid groups && (perm land 0o010) <> 0) || (uid = euid && (perm land 0o100) <> 0)) with Unix.Unix_error _ | Not_found -> false let is_exe_win32 cache dir s = let node = Omake_node.Node.create_node Omake_node.no_mount_info Omake_node.Mount.empty dir s in if is_dir cache node then None else Some node let is_exe_unix cache dir s = let node = Omake_node.Node.create_node Omake_node.no_mount_info Omake_node.Mount.empty dir s in if is_exe_file cache node then Some node else None let is_exe_cygwin cache dir s = let node = Omake_node.Node.create_node Omake_node.no_mount_info Omake_node.Mount.empty dir s in if List.exists (Filename.check_suffix s) win32_suffixes || is_exe_file cache node then Some node else None let ls_exe_path, is_exe, name_exe, exe_suffixes = if Sys.os_type = "Win32" then ls_exe_path_win32, is_exe_win32, String.lowercase_ascii, "" :: win32_suffixes else if Sys.os_type = "Cygwin" then ls_exe_path_win32, is_exe_cygwin, String.lowercase_ascii, "" :: win32_suffixes else ls_exe_path_unix, is_exe_unix, (fun s -> s), [""] let search_exe cache entries = Lm_list_util.some_map (fun (dir, s) -> is_exe cache dir s) entries let exe_find_nodes cache listing s = let entry_ref = Lm_string_set.StringTable.find listing (name_exe s) in match !entry_ref with ExeEntryCore entries -> let nodes = search_exe cache entries in entry_ref := ExeEntryNodes nodes; nodes | ExeEntryNodes nodes -> nodes let exe_find_nodes_all cache listing s = try exe_find_nodes cache listing s with Not_found -> [] let exe_find_item cache listing s = match exe_find_nodes cache listing s with node :: _ -> node | [] -> raise Not_found (* * Find all entries with the given prefix. *) let exe_complete_prefix cache s items listing = Lm_string_set.StringTable.fold (fun items s2 entry_ref -> if Lm_string_util.is_string_prefix s s2 then let nodes = match !entry_ref with ExeEntryCore entries -> let nodes = search_exe cache entries in entry_ref := ExeEntryNodes nodes; nodes | ExeEntryNodes nodes -> nodes in if nodes = [] then items else Lm_string_set.StringSet.add items s2 else items) items listing (************************************************************************ * Redefine the functions to work on directory groups, where each group may * specify auto-rehashing. *) let rec listing_find cache listings s = match listings with [listing] -> listing_find_item cache listing s | listing :: listings -> (try listing_find_item cache listing s with Not_found -> listing_find cache listings s) | [] -> raise Not_found let rec exe_find cache listings s = match listings with [listing] -> exe_find_item cache listing s | listing :: listings -> (try exe_find_item cache listing s with Not_found -> exe_find cache listings s) | [] -> raise Not_found let exe_find_all cache listings s = List.flatten (List.map (fun listing -> exe_find_nodes_all cache listing s) listings) let exe_complete cache listings s = List.fold_left (exe_complete_prefix cache s) Lm_string_set.StringSet.empty listings let ls_dir cache auto_rehash dir = [ls_dir cache auto_rehash dir] let ls_path cache groups = List.map (fun (auto_rehash, dirs) -> ls_path cache auto_rehash dirs) groups let ls_exe_path cache groups = List.map (fun (auto_rehash, dirs) -> ls_exe_path cache auto_rehash dirs) groups omake-0.10.3/src/ir/omake_state.ml0000644000175000017500000001001613177364665015362 0ustar gerdgerd(* * Configuration variables. *) (* * Error codes for various actions. *) let signal_error_code = 127 let fork_error_code = 126 let internal_error_code = 125 let deadlock_error_code = 124 let exn_error_code = 123 let scanner_error_code = 122 (* * Name of the database. *) let db_name = ".omakedb" (* * Name of the makefiles. *) let makefile_name = "OMakefile" let makeroot_name = "OMakeroot" let omake_file_suffix = ".om" let makeroot_short_name = "Root" ^ omake_file_suffix let omake_dir_ref = ref None let cache_dir_ref = ref None let always_use_dotomake = ref false let set_omake_dir dir = let () = try Unix.mkdir dir 0o777 with Unix.Unix_error _ -> () in let dir = if Filename.is_relative dir then try Filename.concat (Unix.getcwd ()) dir with Unix.Unix_error _ -> dir else dir in omake_dir_ref := Some dir; cache_dir_ref := None (* * Directories. *) let lib_dir, lib_dir_reason = let key_name = "SOFTWARE\\MetaPRL\\OMake" in let field_name = "OMAKELIB" in try Sys.getenv field_name, "OMAKELIB environment variable" with Not_found -> try Lm_unix_util.registry_find Lm_unix_util.HKEY_CURRENT_USER key_name field_name, "HKEY_CURRENT_USER\\" ^ key_name ^ "\\" ^ field_name ^ " registry key" with Not_found -> try Lm_unix_util.registry_find Lm_unix_util.HKEY_LOCAL_MACHINE key_name field_name, "HKEY_LOCAL_MACHINE\\" ^ key_name ^ "\\" ^ field_name ^ " registry key" with Not_found -> Omake_magic.lib_dir, "" let home_dir = Lm_unix_util.home_dir let application_dir = Lm_unix_util.application_dir let omakeinit_file = Filename.concat home_dir ".omakeinit" let omakerc_file = Filename.concat home_dir ".omakerc" let oshrc_file = Filename.concat home_dir ".oshrc" let omake_dir () = match !omake_dir_ref with Some dir -> dir | None -> let dirname = Filename.concat application_dir ".omake" in set_omake_dir dirname; dirname (* * Cache directory is separate for each host. *) let cache_dir () = match !cache_dir_ref with | Some dir -> dir | None -> let dirname = Filename.concat (omake_dir ()) "cache" in let () = try Unix.mkdir dirname 0o777 with Unix.Unix_error _ -> () in cache_dir_ref := Some dirname; dirname (* Create cache file hierarchy under the HOME directory *) let cache_file dir name = let dir = match Lm_filename_util.filename_string dir with | AbsolutePath (DriveRoot c, name) -> Filename.concat (String.make 1 c) name | AbsolutePath (NullRoot, name) -> name | RelativePath path -> raise (Invalid_argument ("Omake_state.cache_file: received a relative path: " ^ path)) in let dirname = Filename.concat (cache_dir ()) dir in Lm_filename_util.mkdirhier dirname 0o777; Filename.concat dirname name let open_cache_file dir name = let filename = cache_file dir name in filename, Lm_unix_util.openfile filename [O_RDWR; O_CREAT] 0o666 let get_cache_file dir name = if !always_use_dotomake then open_cache_file dir name else let filename = Filename.concat dir name in try filename, Lm_unix_util.openfile filename [O_RDWR; O_CREAT] 0o666 with Unix.Unix_error _ -> open_cache_file dir name (* * XXX: TODO: We use lockf, but it is not NFS-safe if filesystem is mounted w/o locking. * Also, lockf is not always supported, so we may raise an exception for a "wrong" reason. * May be we should implement a "sloppy" locking as well - see * also the mailing list discussions: * - http://lists.metaprl.org/pipermail/omake/2005-November/thread.html#744 * - http://lists.metaprl.org/pipermail/omake-devel/2005-November/thread.html#122 *) let lock_file fd mode = Lm_unix_util.lockf fd mode 0 let db_file () = Filename.concat (omake_dir ()) db_name let history_file () = Filename.concat (omake_dir ()) "osh_history" omake-0.10.3/src/ir/omake_lexer.ml0000644000175000017500000000104613177364665015364 0ustar gerdgerd(* * We build lexers from channels. *) (* * An action is a symbol. *) module LexerAction = struct type action = Lm_symbol.t let choose = max let pp_print_action = Lm_symbol.pp_print_symbol let hash : action -> int = Hashtbl.hash let compare = Lm_symbol.compare end module Lexer = Lm_lexer.MakeLexer (Lm_channel.LexerInput) (LexerAction);; (* * Some extra functions. *) let lexer_of_string s = snd (Lexer.add_clause Lexer.empty Omake_symbol.lex_sym s) let lexer_matches info s = Lexer.matches info (Lm_channel.of_string s) omake-0.10.3/src/ir/omake_symbol.ml0000644000175000017500000002607613177364665015564 0ustar gerdgerd(* * Symbols used everywhere. * Eventually, we should collect all the global symbols and * put them here. *) let braces_sym = Lm_symbol.add "{}" let builtin_sym = Lm_symbol.add "$builtin" let map_sym = Lm_symbol.add "$map" let pervasives_sym = Lm_symbol.add "Pervasives" let object_sym = Lm_symbol.add "Object" let int_object_sym = Lm_symbol.add "Int" let float_object_sym = Lm_symbol.add "Float" let string_object_sym = Lm_symbol.add "String" let sequence_object_sym = Lm_symbol.add "Sequence" let array_object_sym = Lm_symbol.add "Array" let fun_object_sym = Lm_symbol.add "Fun" let rule_object_sym = Lm_symbol.add "Rule" let file_object_sym = Lm_symbol.add "File" let dir_object_sym = Lm_symbol.add "Dir" let body_object_sym = Lm_symbol.add "Body" let in_channel_object_sym = Lm_symbol.add "InChannel" let out_channel_object_sym = Lm_symbol.add "OutChannel" let in_out_channel_object_sym = Lm_symbol.add "InOutChannel" let map_object_sym = Lm_symbol.add "Map" let shell_object_sym = Lm_symbol.add "Shell" let select_object_sym = Lm_symbol.add "Select" let pipe_object_sym = Lm_symbol.add "Pipe" let stat_object_sym = Lm_symbol.add "Stat" let passwd_object_sym = Lm_symbol.add "Passwd" let group_object_sym = Lm_symbol.add "Group" let lexer_object_sym = Lm_symbol.add "Lexer" let parser_object_sym = Lm_symbol.add "Parser" let location_object_sym = Lm_symbol.add "Location" let target_object_sym = Lm_symbol.add "Target" let options_object_sym = Lm_symbol.add "Options" let var_object_sym = Lm_symbol.add "Var" let tm_object_sym = Lm_symbol.add "Tm" let wild_sym = Lm_symbol.add "%" let explicit_target_sym = Lm_symbol.add "$EXPLICIT-TARGET" let current_prec_sym = Lm_symbol.add "current-prec" let lex_sym = Lm_symbol.add "lex" let name_sym = Lm_symbol.add "name" (* let value_sym = Lm_symbol.add "value" *) let lexer_sym = Lm_symbol.add "lexer" let val_sym = Lm_symbol.add "val" let read_sym = Lm_symbol.add "read" let write_sym = Lm_symbol.add "write" let error_sym = Lm_symbol.add "error" let st_dev_sym = Lm_symbol.add "st_dev" let st_ino_sym = Lm_symbol.add "st_ino" let st_kind_sym = Lm_symbol.add "st_kind" let st_perm_sym = Lm_symbol.add "st_perm" let st_nlink_sym = Lm_symbol.add "st_nlink" let st_uid_sym = Lm_symbol.add "st_uid" let st_gid_sym = Lm_symbol.add "st_gid" let st_rdev_sym = Lm_symbol.add "st_rdev" let st_size_sym = Lm_symbol.add "st_size" let st_atime_sym = Lm_symbol.add "st_atime" let st_mtime_sym = Lm_symbol.add "st_mtime" let st_ctime_sym = Lm_symbol.add "st_ctime" let pw_name_sym = Lm_symbol.add "pw_name" let pw_passwd_sym = Lm_symbol.add "pw_passwd" let pw_uid_sym = Lm_symbol.add "pw_uid" let pw_gid_sym = Lm_symbol.add "pw_gid" let pw_gecos_sym = Lm_symbol.add "pw_gecos" let pw_dir_sym = Lm_symbol.add "pw_dir" let pw_shell_sym = Lm_symbol.add "pw_shell" let gr_name_sym = Lm_symbol.add "gr_name" let gr_passwd_sym = Lm_symbol.add "gr_passwd" let gr_gid_sym = Lm_symbol.add "gr_gid" let gr_mem_sym = Lm_symbol.add "gr_mem" let tm_sec_sym = Lm_symbol.add "tm_sec" let tm_min_sym = Lm_symbol.add "tm_min" let tm_hour_sym = Lm_symbol.add "tm_hour" let tm_mday_sym = Lm_symbol.add "tm_mday" let tm_mon_sym = Lm_symbol.add "tm_mon" let tm_year_sym = Lm_symbol.add "tm_year" let tm_wday_sym = Lm_symbol.add "tm_wday" let tm_yday_sym = Lm_symbol.add "tm_yday" let tm_isdst_sym = Lm_symbol.add "tm_isdst" let tm_time_sym = Lm_symbol.add "tm_time" let target_sym = Lm_symbol.add "target" let target_effects_sym = Lm_symbol.add "effects" let scanner_deps_sym = Lm_symbol.add "scanner-deps" let static_deps_sym = Lm_symbol.add "static-deps" let build_deps_sym = Lm_symbol.add "build-deps" let build_values_sym = Lm_symbol.add "build-values" let build_commands_sym = Lm_symbol.add "build-commands" let output_file_sym = Lm_symbol.add "output-file" let argv_sym = Lm_symbol.add "argv" let star_sym = Lm_symbol.add "*" let at_sym = Lm_symbol.add "@" let amp_sym = Lm_symbol.add "&" let lt_sym = Lm_symbol.add "<" let gt_sym = Lm_symbol.add ">" let plus_sym = Lm_symbol.add "+" let hat_sym = Lm_symbol.add "^" let zero_sym = Lm_symbol.add "0" let runtime_exception_sym = Lm_symbol.add "RuntimeException" let unbuildable_exception_sym = Lm_symbol.add "UnbuildableException" let parse_loc_sym = Lm_symbol.add "parse-loc" let loc_sym = Lm_symbol.add "loc" let pos_sym = Lm_symbol.add "position" let message_sym = Lm_symbol.add "message" let stdin_sym = Lm_symbol.add "stdin" let stdout_sym = Lm_symbol.add "stdout" let stderr_sym = Lm_symbol.add "stderr" let printexitvalue_sym = Lm_symbol.add "printexitvalue" let targets_sym = Lm_symbol.add "TARGETS" let glob_options_sym = Lm_symbol.add "GLOB_OPTIONS" let glob_allow_sym = Lm_symbol.add "GLOB_ALLOW" let glob_ignore_sym = Lm_symbol.add "GLOB_IGNORE" let this_sym = Lm_symbol.add "this" let dynamic_sym = Lm_symbol.add "dynamic" let static_sym = Lm_symbol.add "static" let allow_empty_subdirs_sym = Lm_symbol.add "ALLOW_EMPTY_SUBDIRS" let abort_on_command_error_sym = Lm_symbol.add "ABORT_ON_COMMAND_ERROR" let exit_on_uncaught_exception_sym = Lm_symbol.add "EXIT_ON_UNCAUGHT_EXCEPTION" let create_subdirs_sym = Lm_symbol.add "CREATE_SUBDIRS" let scanner_mode_sym = Lm_symbol.add "SCANNER_MODE" let history_file_sym = Lm_symbol.add "history-file" let history_length_sym = Lm_symbol.add "history-length" let build_summary_sym = Lm_symbol.add "BUILD_SUMMARY" (* * Special symbols. *) let concat_sym = Lm_symbol.add "concat" let if_sym = Lm_symbol.add "if" let else_sym = Lm_symbol.add "else" let elseif_sym = Lm_symbol.add "elseif" let switch_sym = Lm_symbol.add "switch" let select_sym = Lm_symbol.add "select" let case_sym = Lm_symbol.add "case" let do_sym = Lm_symbol.add "do" let while_sym = Lm_symbol.add "while" let default_sym = Lm_symbol.add "default" let include_sym = Lm_symbol.add "include" let section_sym = Lm_symbol.add "section" let try_sym = Lm_symbol.add "try" let catch_sym = Lm_symbol.add "catch" let when_sym = Lm_symbol.add "when" let finally_sym = Lm_symbol.add "finally" let curry_sym = Lm_symbol.add "curry" let private_sym = Lm_symbol.add "private" let protected_sym = Lm_symbol.add "protected" let public_sym = Lm_symbol.add "public" let global_sym = Lm_symbol.add "global" let const_sym = Lm_symbol.add "const" let rule_sym = Lm_symbol.add "rule" let system_sym = Lm_symbol.add "system" let open_sym = Lm_symbol.add "open" let autoload_sym = Lm_symbol.add "autoload" let declare_sym = Lm_symbol.add "declare" let return_sym = Lm_symbol.add "return" let export_sym = Lm_symbol.add "export" let value_sym = Lm_symbol.add "value" let file_sym = Lm_symbol.add "__FILE__" let file_id_sym = Lm_symbol.add "__ID__" let foreach_sym = Lm_symbol.add "foreach" let fun_sym = Lm_symbol.add "fun" let set_sym = Lm_symbol.add "set" let neg_fun_sym = Lm_symbol.add "neg" let add_fun_sym = Lm_symbol.add "add" let sub_fun_sym = Lm_symbol.add "sub" let mul_fun_sym = Lm_symbol.add "mul" let div_fun_sym = Lm_symbol.add "div" let mod_fun_sym = Lm_symbol.add "mod" let lsl_fun_sym = Lm_symbol.add "lsl" let lsr_fun_sym = Lm_symbol.add "lsr" let asr_fun_sym = Lm_symbol.add "asr" let lxor_fun_sym = Lm_symbol.add "lxor" let lor_fun_sym = Lm_symbol.add "lor" let land_fun_sym = Lm_symbol.add "land" let and_fun_sym = Lm_symbol.add "and" let or_fun_sym = Lm_symbol.add "or" let le_fun_sym = Lm_symbol.add "le" let lt_fun_sym = Lm_symbol.add "lt" let equal_fun_sym = Lm_symbol.add "equal" let nequal_fun_sym = Lm_symbol.add "nequal" let ge_fun_sym = Lm_symbol.add "ge" let gt_fun_sym = Lm_symbol.add "gt" let nth_fun_sym = Lm_symbol.add "nth" let memo_rule_sym = Lm_symbol.add "memo-rule" let empty_map_sym = Lm_symbol.add "empty-map" let create_map_sym = Lm_symbol.add "create-map" let create_lazy_map_sym = Lm_symbol.add "create-lazy-map" (* * Awk values. *) let awk_sym = Lm_symbol.add "awk" let nf_sym = Lm_symbol.add "NF" let rs_sym = Lm_symbol.add "RS" let fs_sym = Lm_symbol.add "FS" let filename_sym = Lm_symbol.add "FILENAME" let fnr_sym = Lm_symbol.add "FNR" let fsubst_sym = Lm_symbol.add "fsubst" (* * The applications that can have cases. *) let cases_syms = [awk_sym; fsubst_sym] let cases_set = List.fold_left Lm_symbol.SymbolSet.add Lm_symbol.SymbolSet.empty cases_syms let clauses_syms = [case_sym; default_sym; when_sym; catch_sym; finally_sym; do_sym] let clauses_set = List.fold_left Lm_symbol.SymbolSet.add Lm_symbol.SymbolSet.empty clauses_syms (* * Colon symbols. *) let normal_sym = Lm_symbol.add ":normal:" let optional_sym = Lm_symbol.add ":optional:" let exists_sym = Lm_symbol.add ":exists:" let squash_sym = Lm_symbol.add ":squash:" let effects_sym = Lm_symbol.add ":effects:" let scanner_sym = Lm_symbol.add ":scanner:" let values_sym = Lm_symbol.add ":value:" let key_sym = Lm_symbol.add ":key:" (* * Builtin functions. *) let extends_sym = Lm_symbol.add "extends" let omakeflags_sym = Lm_symbol.add "OMakeFlags" let omakeargv_sym = Lm_symbol.add "OMakeArgv" (* * Symbols. *) let prompt_sym = Lm_symbol.add "prompt" let ignoreeof_sym = Lm_symbol.add "ignoreeof" let cwd_sym = Lm_symbol.add "CWD" let stdroot_sym = Lm_symbol.add "STDROOT" let stdlib_sym = Lm_symbol.add "STDLIB" let ostype_sym = Lm_symbol.add "OSTYPE" let path_sym = Lm_symbol.add "PATH" let auto_rehash_sym = Lm_symbol.add "AUTO_REHASH" let omakepath_sym = Lm_symbol.add "OMAKEPATH" let oshell_sym = Lm_symbol.add "OSHELL" let cdpath_sym = Lm_symbol.add "cdpath" omake-0.10.3/src/ir/omake_parser.ml0000644000175000017500000000142213177364665015537 0ustar gerdgerd(* * The OMake version of the parser uses symbols. *) module Parser = struct module ParserArg = struct type symbol = Lm_symbol.t let to_string = Lm_symbol.to_string let pp_print_symbol = Lm_symbol.pp_print_symbol let hash_symbol = Hashtbl.hash let compare_symbol = Lm_symbol.compare let eof = Lm_symbol.add "" module Action = Omake_lexer.LexerAction;; type action = Action.action let hash_action = Action.hash let compare_action = Action.compare let pp_print_action = Action.pp_print_action end include Lm_parser.MakeParser (ParserArg) (Lm_parser.ParserPrecedence) let empty = add_prec empty prec_min (Lm_symbol.add ".min") let empty = add_prec empty prec_max (Lm_symbol.add ".max") end omake-0.10.3/src/ir/omake_command.ml0000644000175000017500000000432313177364666015665 0ustar gerdgerd (************************************************************************ * Argument collapsing. *) type arg_buffer = Omake_command_type.arg_string list let arg_buffer_empty = [] let arg_buffer_add_string buf s = Omake_command_type.ArgString s :: buf let arg_buffer_add_data buf s = Omake_command_type.ArgData s :: buf let rec collect_string buf args = match args with Omake_command_type.ArgString s :: args -> Buffer.add_string buf s; collect_string buf args | _ -> args let rec collect_data buf args = match args with Omake_command_type.ArgData s :: args -> Buffer.add_string buf s; collect_data buf args | _ -> args let arg_buffer_contents args = let buf = Buffer.create 32 in let rec collect args' args = match args with Omake_command_type.ArgString s :: ((ArgString _ :: _) as tl) -> Buffer.add_string buf s; let args = collect_string buf tl in let s = Buffer.contents buf in Buffer.clear buf; collect (Omake_command_type.ArgString s :: args') args | ArgData s :: ((ArgData _ :: _) as tl) -> Buffer.add_string buf s; let args = collect_data buf tl in let s = Buffer.contents buf in Buffer.clear buf; collect (ArgData s :: args') args | h :: args -> collect (h :: args') args | [] -> List.rev args' in collect [] (List.rev args) (************************************************************************ * Command utilities *) (* * Parse the command lines from the strings. *) let parse_command venv dir target loc flags line = { Omake_command_type.command_loc = loc; command_dir = dir; command_target = target; command_flags = flags; command_venv = venv; command_inst = line } let parse_commands venv dir target loc lines = List.map (fun (flags, line) -> parse_command venv dir target loc flags line) lines (* * Allow output in the command. *) let command_allow_output command = { command with Omake_command_type.command_flags = AllowOutputFlag :: command.Omake_command_type.command_flags } omake-0.10.3/src/ir/omake_install.ml0000644000175000017500000000436313177364666015721 0ustar gerdgerd(* * Functions to install OMakefiles into a project. *) (* * Copy a file into a directory, but prompt the user if * the file already exists. *) let copy_file force src dst = let prompt () = Lm_printf.printf "%s already exists, overwrite (yes/no)? " dst; Lm_printf.flush Lm_printf.std_formatter; String.lowercase_ascii (input_line stdin) = "yes" in if force || not (Sys.file_exists dst) || prompt () then let () = Lm_printf.printf "*** omake: creating %s@." dst in let inx = Pervasives.open_in src in let outx = Pervasives.open_out dst in let rec copy () = Pervasives.output_char outx (input_char inx); copy () in let () = try copy () with End_of_file -> () in close_in inx; close_out outx else Lm_printf.printf "*** omake: skipping %s@." dst (* * Names of the standard files. *) let omakeroot = Omake_node.Node.fullname (Omake_node.Node.create_node Omake_node.no_mount_info Omake_node.Mount.empty Omake_node.Dir.lib "OMakeroot.default") let omakefile = Omake_node.Node.fullname (Omake_node.Node.create_node Omake_node.no_mount_info Omake_node.Mount.empty Omake_node.Dir.lib "OMakefile.default") (* * Install just into the current directory. *) let install_current force = copy_file force omakeroot "OMakeroot"; copy_file force omakefile "OMakefile"; Lm_printf.printf "*** omake: project files OMakefile and OMakeroot have been installed\n"; Lm_printf.printf "*** omake: you should edit these files before continuing@." (* * Install into all subdirectories. *) let glob_cvs_ignore = Lm_glob.create_options [GlobCVSIgnore] let install_subdirs force = let dirs = Lm_glob.subdirs_of_dirs glob_cvs_ignore "" ["."] in copy_file force omakeroot "OMakeroot"; List.iter (fun dir -> copy_file force omakefile (Filename.concat dir "OMakefile")) dirs; Lm_printf.printf "*** omake: project files OMakefile and OMakeroot have been installed\n"; Lm_printf.printf "*** omake: OMakefiles have been installed into all subdirectories\n"; Lm_printf.printf "*** omake: you should edit these files before continuing@." omake-0.10.3/src/ir/omake_options.ml0000644000175000017500000003555313177364666015753 0ustar gerdgerd(* * When to print output. *) type eval_flag = | EvalNever | EvalLazy | EvalEager (* * Diversion control. *) type output_flag = | OutputNormal | OutputPostponeSuccess | OutputPostponeError | OutputRepeatErrors (* * Make the default state explicit (the actual value may depend on the value of other settings). *) type setting = | Default | Set of bool (* * The basic make flags. *) type t = { job_count : int; remote_servers : (string * int) list; terminate_on_error : setting; dry_run : bool; print_command : eval_flag; print_dir : bool; print_file : bool; print_status : bool; print_exit : bool; mutable print_progress : setting; verbose : bool; touch_only : bool; flush_cache : bool; flush_dependencies : bool; print_dependencies : bool; show_dependencies : string list; all_dependencies : bool; verbose_dependencies : bool; cd_root : bool; project : bool; poll : setting; osh : bool; poll_on_done : bool; flush_include : bool; flush_static : bool; allow_exceptions : bool; absname : bool; output : (output_flag * bool) list; (* Warnings *) warn_declare : bool; warn_error : bool } let opt_job_count opts = opts.job_count let opt_remote_servers opts = opts.remote_servers (* * Predicate returns true iff there are parallel jobs. *) let opt_parallel options = (opt_job_count options) > 1 || (opt_remote_servers options) <> [] let set_job_count_and_servers_opt opts cnt srvs = { opts with job_count = cnt; remote_servers = srvs } (* * The argument string is a colon-separated list of server specification. * A server spec can be: * 1. a number: this specifies the job_count * 2. a machine: this specified a remote server that will handle 1 job * 3. a machine=count: a remote server that will handle jobs *) let get_job_count (s : string) : int * (string * int) list = let set_job (job_count, remote_servers) job = match Lm_string_util.bi_split '=' job with | (machine,count) -> let count = try int_of_string count with Failure _ -> 1 in job_count, (machine, count) :: remote_servers | exception Not_found -> try int_of_string job, remote_servers with Failure _ -> job_count, (job, 1) :: remote_servers in let job_count, remote_servers = List.fold_left (fun acc x -> set_job acc x) (1, []) (Lm_string_util.split ":" s) in job_count , List.rev remote_servers let set_job_count (options : t) (s: string) : t = let job_count, remote_servers = get_job_count s in set_job_count_and_servers_opt options (max 1 job_count) remote_servers let set_dry_run_opt opts flag = { opts with dry_run = flag } let opt_print_command opts = opts.print_command let set_print_command_opt opts flag = { opts with print_command = flag } let opt_print_dir opts = opts.print_dir let set_print_dir_opt opts flag = { opts with print_dir = flag } let opt_print_file opts = opts.print_file let set_print_file_opt opts flag = { opts with print_file = flag } let opt_print_status opts = opts.print_status let set_print_status_opt opts flag = { opts with print_status = flag } let opt_print_exit opts = opts.print_exit let set_print_exit_opt opts flag = { opts with print_exit = flag } let opt_print_progress opts = match opts.print_progress with | Set b -> b | Default -> let ok_to_print = Unix.isatty Unix.stdout in opts.print_progress <- Set ok_to_print; ok_to_print let set_print_progress_opt opts flag = { opts with print_progress = Set flag } let opt_touch_only opts = opts.touch_only let set_touch_only_opt opts flag = { opts with touch_only = flag } let opt_flush_cache opts = opts.flush_cache let set_flush_cache_opt opts flag = { opts with flush_cache = flag } let opt_flush_dependencies opts = opts.flush_dependencies let set_flush_dependencies_opt opts flag = { opts with flush_dependencies = flag } let set_print_dependencies_opt opts flag = { opts with print_dependencies = flag } let add_show_dependency_opt opts dep = { opts with show_dependencies = dep :: opts.show_dependencies } let opt_all_dependencies opts = opts.all_dependencies let set_all_dependencies_opt opts flag = { opts with all_dependencies = flag } let opt_verbose opts = opts.verbose let opt_verbose_dependencies opts = opts.verbose_dependencies let set_verbose_dependencies_opt opts flag = { opts with verbose_dependencies = flag } let opt_cd_root opts = opts.cd_root let set_cd_root_opt opts flag = { opts with cd_root = flag } let opt_project opts = opts.project let set_project_opt opts flag = { opts with project = flag } let opt_poll_on_done opts = opts.poll_on_done let set_poll_on_done_opt opts b = { opts with poll_on_done = b } let opt_poll opts = match opts.poll with | Set v -> v | Default -> (opt_poll_on_done opts) let set_poll_opt opts b = { opts with poll = Set b } let opt_osh opts = opts.osh let set_osh_opt opts = { opts with osh = true } let opt_terminate_on_error opts = match opts.terminate_on_error with | Set v -> v | Default -> not (opt_poll opts) let set_terminate_on_error_opt opts flag = { opts with terminate_on_error = Set flag } let opt_flush_include opts = opts.flush_include let set_flush_include_opt opts flag = { opts with flush_include = flag } let opt_flush_static opts = opts.flush_static let set_flush_static_opt opts flag = { opts with flush_static = flag } let opt_allow_exceptions opts = opts.allow_exceptions let set_allow_exceptions_opt opts flag = { opts with allow_exceptions = flag } let opt_absname opts = opts.absname let set_absname_opt opts flag = { opts with absname = flag } let opt_warn_declare opts = opts.warn_declare let set_warn_declare_opt opts flag = { opts with warn_declare = flag } let opt_warn_error opts = opts.warn_error let set_warn_error_opt opts flag = { opts with warn_error = flag } (* * Output control. *) let output_opt_char (options : t) (c : char) : t = match c with | '0' -> (* -s --output-errors-only --no--progress *) { options with print_status = false; print_dir = false; print_file = false; print_exit = false; print_command = EvalNever; print_progress = Set false; output = [(OutputPostponeError, true)] } | '1' -> (* -S --progress --output-errors-only *) { options with print_command = EvalLazy; print_progress = Set true; output = [(OutputPostponeError, true)] } | '2' -> (* --progress --output-postpone *) { options with print_progress = Set true; output = [(OutputPostponeSuccess, true); (OutputPostponeError, true)] } | 'W' -> set_print_dir_opt options true | 'w' -> set_print_dir_opt options false | 'P' -> set_print_progress_opt options true | 'p' -> set_print_progress_opt options false | 'X' -> set_print_exit_opt options true | 'x' -> set_print_exit_opt options false | 'S' -> set_print_status_opt options true | 's' -> set_print_status_opt options false | _ -> (* Ignore, for forward compatibility *) options ;; let set_output_opts (options : t) (s : string) : t = Lm_string_util.fold_left (fun opt char -> output_opt_char opt char) options s let rec opt_output (opts : t) (flag : output_flag) : bool = let answer = try Some(List.assoc flag opts.output) with Not_found -> None in (* A few extra wrinkles *) match answer, flag with | Some true, _ -> (* Everything should be on when explicitly enabled *) true | (Some false | None), OutputPostponeError -> (* If successes are printed, errors should be too, no matter what *) opt_output opts OutputPostponeSuccess | Some false, _ -> (* Everything else should be off when explicitly disabled *) false | None, OutputNormal -> not (opt_output opts OutputPostponeSuccess || opt_output opts OutputPostponeError) | None, OutputRepeatErrors -> (* default is "on iff -k/-p/-P" *) not (opt_terminate_on_error opts) | None, OutputPostponeSuccess -> (* off by default *) false let set_output_opt flag opts on = let flags = (flag, on) :: (List.remove_assoc flag opts.output) in { opts with output = flags } let opt_divert opts = List.exists (opt_output opts) [OutputPostponeSuccess; OutputPostponeError; OutputRepeatErrors] (* * Default options. *) let default_options = { job_count = max (Lm_terminfo.get_number_of_cores ()) 1; remote_servers = []; terminate_on_error = Default; dry_run = false; print_command = EvalLazy; print_dir = false; print_file = true; print_status = true; print_exit = false; print_progress = Default; verbose = false; touch_only = false; flush_cache = false; flush_dependencies = false; print_dependencies = false; show_dependencies = []; all_dependencies = false; verbose_dependencies = false; cd_root = false; project = false; poll = Default; poll_on_done = false; osh = false; flush_include = false; flush_static = false; allow_exceptions = false; absname = false; output = []; warn_declare = false; warn_error = false; } (* * Argument specifier. * * NOTE! This set of options is functional and scoped in OMakefiles. * Global, non-scoped options that assign to reference cells should be * put in the option list in Omake_main, not here. *) let options_spec = ["-j", Lm_arg.StringFold set_job_count, (**) "Specify parallel jobs and remote servers"; "-k", Lm_arg.ClearFold set_terminate_on_error_opt, (**) "Do not stop when an error occurs; implied by -p and -P"; "-p", Lm_arg.SetFold set_poll_opt, (**) "Poll filesystem for changes (until build succeeds); implies -k"; "-P", Lm_arg.SetFold set_poll_on_done_opt, (**) "Poll filesystem for changes (keep polling \"forever\"); implies -k and -p"; "-n", Lm_arg.SetFold set_dry_run_opt, (**) "Print commands, but do not execute them"; "--project", Lm_arg.SetFold set_project_opt, (**) "Ignore the current directory and build the project"; "-t", Lm_arg.SetFold set_touch_only_opt, (**) "Update database to force files to be up-to-date"; "--depend", Lm_arg.SetFold set_flush_dependencies_opt, (**) "Do not trust cached dependecy information"; "-U", Lm_arg.SetFold set_flush_cache_opt, (**) "Do not trust the dependency cache or cached OMakefiles"; "--flush-includes", Lm_arg.SetFold set_flush_include_opt, (**) "Do not trust cached .omc files"; "--configure", Lm_arg.SetFold set_flush_static_opt, (**) "Recompute static. sections"; "-R", Lm_arg.SetFold set_cd_root_opt, (**) "Command-line targets are relative to the project root; builds all .DEFAULT targets if no targets given"; "--print-dependencies", Lm_arg.SetFold set_print_dependencies_opt, (**) "Build and print dependencies"; "--show-dependencies", Lm_arg.StringFold add_show_dependency_opt, (**) "Show dependencies if the file is built"; "--all-dependencies", Lm_arg.SetFold set_all_dependencies_opt, (**) "For --print-dependencies and --show-dependencies, print dependencies recursively"; "--verbose-dependencies", Lm_arg.SetFold set_verbose_dependencies_opt, (**) "For --print-dependencies and --show-dependencies, print all dependencies too"; "--absname", Lm_arg.SetFold set_absname_opt, (**) "Filenames are always displayed as absolute paths"; "-Wdeclare", Lm_arg.SetFold set_warn_declare_opt, (**) "Warn about undeclared variables"; "-warn-error", Lm_arg.SetFold set_warn_error_opt, (**) "Treat warnings as errors" ] let progress_usage = match Sys.os_type with | "Unix" | "Cygwin" -> "(enabled by default when the stdout is a terminal)" | "Windows" -> "(default)" | _ -> (* Should not happen *) "(may be enabled by default)" (* * Output control. *) let output_spec = [ "--verbose", Lm_arg.UnitFold (fun options -> { options with print_command = EvalEager; verbose = true; print_status = true; print_exit = true; print_file = true }), "Verbose output (equivalent to \"--no-S --print-status --print-exit VERBOSE=true\")"; "--print-exit", Lm_arg.SetFold set_print_exit_opt, "Print the exit codes of commands"; "-S", Lm_arg.SetFold (fun options b -> { options with print_command = if b then EvalLazy else EvalEager }), "Print command only if the command prints output (default)"; "-s", Lm_arg.ClearFold (fun options b -> { options with print_status = b; print_dir = b; print_file = b; print_exit = b; print_command = if b then EvalEager else EvalNever }), "Never print commands before they are executed"; "--progress", Lm_arg.SetFold set_print_progress_opt, ("Print a progress indicator " ^ progress_usage); "--print-status", Lm_arg.SetFold set_print_status_opt, "Print status lines (default)"; "-w", Lm_arg.SetFold set_print_dir_opt, "Print the directory in \"make format\" as commands are executed"; "--output-normal", Lm_arg.SetFold (set_output_opt OutputNormal), "Relay the output of the rule commands to the OMake output right away. This is the default when no --output-postpone and no --output-only-errors flags are given."; "--output-postpone", Lm_arg.SetFold (fun opt flag -> set_output_opt OutputPostponeSuccess (set_output_opt OutputPostponeError opt flag) flag), "Postpone printing command output until a rule terminates."; "--output-only-errors", Lm_arg.SetFold (set_output_opt OutputPostponeError), "Same as --output-postpone, but postponed output will only be printed for commands that fail."; "--output-at-end", Lm_arg.SetFold (set_output_opt OutputRepeatErrors), "The output of the failed commands will be printed after OMake have stopped. Off by default, unless -k is enabled (directly or via -p/-P)."; "-o", Lm_arg.StringFold set_output_opts, (**) "Short output options [01jwWpPxXsS] (see the manual)"; ] omake-0.10.3/src/ir/omake_ir_util.ml0000644000175000017500000000554613177364666015726 0ustar gerdgerd module SimpleVarCompare = struct type t = Omake_ir.simple_var_info let compare (s1, v1) (s2, v2) = match s1, s2 with Omake_ir.VarScopePrivate, Omake_ir.VarScopePrivate | VarScopeThis, VarScopeThis | VarScopeVirtual, VarScopeVirtual | VarScopeGlobal, VarScopeGlobal -> Lm_symbol.compare v1 v2 | VarScopePrivate, VarScopeThis | VarScopePrivate, VarScopeVirtual | VarScopePrivate, VarScopeGlobal | VarScopeThis, VarScopeVirtual | VarScopeThis, VarScopeGlobal | VarScopeVirtual, VarScopeGlobal -> -1 | VarScopeThis, VarScopePrivate | VarScopeVirtual, VarScopePrivate | VarScopeVirtual, VarScopeThis | VarScopeGlobal, VarScopePrivate | VarScopeGlobal, VarScopeThis | VarScopeGlobal, VarScopeVirtual -> 1 end;; module SimpleVarSet = Lm_set.LmMake (SimpleVarCompare);; module SimpleVarTable = Lm_map.LmMake (SimpleVarCompare);; (************************************************************************ * Variable tables. The const_flag and protected_flag are just * comments, and aren't part of the comparison. *) module VarInfoCompare = struct type t = Omake_ir.var_info let compare info1 info2 = match info1, info2 with |Omake_ir.VarPrivate (_, v1), Omake_ir.VarPrivate (_, v2) | VarThis (_, v1), VarThis (_, v2) | VarVirtual (_, v1), VarVirtual (_, v2) | VarGlobal (_, v1), VarGlobal (_, v2) -> Lm_symbol.compare v1 v2 | VarPrivate _, VarThis _ | VarPrivate _, VarVirtual _ | VarPrivate _, VarGlobal _ | VarThis _, VarVirtual _ | VarThis _, VarGlobal _ | VarVirtual _, VarGlobal _ -> -1 | VarThis _, VarPrivate _ | VarVirtual _, VarPrivate _ | VarVirtual _, VarThis _ | VarGlobal _, VarPrivate _ | VarGlobal _, VarThis _ | VarGlobal _, VarVirtual _ -> 1 end;; module VarInfoSet = Lm_set.LmMake (VarInfoCompare);; module VarInfoTable = Lm_map.LmMake (VarInfoCompare);; let var_equal v1 v2 = VarInfoCompare.compare v1 v2 = 0 let var_of_var_info = function Omake_ir.VarPrivate (loc, v) | VarThis (loc, v) | VarVirtual (loc, v) | VarGlobal (loc, v) -> loc, v let loc_of_exp e = match e with | Omake_ir.LetVarExp (loc, _, _, _, _) | KeyExp (loc, _) | LetKeyExp (loc, _, _, _) | LetFunExp (loc, _, _, _, _, _, _, _) | LetObjectExp (loc, _, _, _, _, _) | LetThisExp (loc, _) | ShellExp (loc, _) | IfExp (loc, _) | SequenceExp (loc, _) | SectionExp (loc, _, _, _) | OpenExp (loc, _) | IncludeExp (loc, _, _) | ApplyExp (loc, _, _, _) | SuperApplyExp (loc, _, _, _, _) | MethodApplyExp (loc, _, _, _, _) | StaticExp (loc, _, _, _) | ReturnBodyExp (loc, _, _) | StringExp (loc, _) | ReturnExp (loc, _, _) | ReturnObjectExp (loc, _) | ReturnSaveExp loc -> loc omake-0.10.3/src/ir/omake_value_print.mli0000644000175000017500000000167213177364666016754 0ustar gerdgerd val pp_print_target : Omake_value_type.target Lm_printf.t val pp_print_wild_list : Lm_wild.in_patt list Lm_printf.t val pp_print_source_list : ('a * Omake_value_type.source_core) list Lm_printf.t val pp_print_value : Omake_value_type.t Lm_printf.t val pp_print_simple_value : Omake_value_type.t Lm_printf.t val pp_print_value_list : Omake_value_type.t list Lm_printf.t val pp_print_path : Omake_value_type.path Lm_printf.t val pp_print_item : Omake_value_type.item Lm_printf.t val pp_print_exn : Omake_value_type.omake_error Lm_printf.t (* Helpers, used in printing and for $(Fun.arity) function *) val fun_arity : Omake_value_type.keyword_param_value list -> Omake_ir.param list -> Omake_ir.arity val curry_fun_arity : Omake_value_type.param_value list -> Omake_value_type.keyword_param_value list -> Omake_ir.param list -> Omake_value_type.keyword_value list -> Omake_ir.arity omake-0.10.3/src/ir/omake_value_util.mli0000644000175000017500000000653413177364666016577 0ustar gerdgerd(* module type PosSig = *) (* sig *) (* val loc_exp_pos : Lm_location.t -> Omake_value_type.pos *) (* val loc_pos : *) (* Lm_location.t -> Omake_value_type.pos -> Omake_value_type.pos *) (* val ast_exp_pos : Omake_ast.exp -> Omake_value_type.pos *) (* val ir_exp_pos : Omake_ir.exp -> Omake_value_type.pos *) (* val var_exp_pos : Omake_ir.var -> Omake_value_type.pos *) (* val string_exp_pos : string -> Omake_value_type.pos *) (* val value_exp_pos : Omake_value_type.value -> Omake_value_type.pos *) (* val string_pos : string -> Omake_value_type.pos -> Omake_value_type.pos *) (* val pos_pos : *) (* Omake_value_type.pos -> Omake_value_type.pos -> Omake_value_type.pos *) (* val int_pos : int -> Omake_value_type.pos -> Omake_value_type.pos *) (* val var_pos : *) (* Omake_ir.var -> Omake_value_type.pos -> Omake_value_type.pos *) (* val error_pos : *) (* Omake_value_type.omake_error -> *) (* Omake_value_type.pos -> Omake_value_type.pos *) (* val del_pos : *) (* (Format.formatter -> unit) -> Lm_location.t -> Omake_value_type.pos *) (* val del_exp_pos : *) (* (Format.formatter -> unit) -> *) (* Omake_value_type.pos -> Omake_value_type.pos *) (* val loc_of_pos : Omake_value_type.pos -> Lm_location.t *) (* val pp_print_pos : Format.formatter -> Omake_value_type.pos -> unit *) (* end *) val empty_obj : 'a Lm_symbol.SymbolTable.t val class_sym : Lm_symbol.t val venv_get_class : Omake_value_type.t Lm_symbol.SymbolTable.t -> Omake_value_type.obj Lm_symbol.SymbolTable.t module ValueCompare : sig type t = Omake_value_type.t val check_simple : Omake_value_type.pos -> Omake_value_type.t -> unit val check : Omake_value_type.pos -> Omake_value_type.t -> Omake_value_type.t val tag : Omake_value_type.t -> int val compare : Omake_value_type.t -> Omake_value_type.t -> int val compare_list : Omake_value_type.t list -> Omake_value_type.t list -> int end module ValueTable : sig type key = ValueCompare.t type 'a t = (ValueCompare.t, 'a) Lm_map.tree val empty : 'a t val is_empty : 'a t -> bool val cardinal : 'a t -> int val add : 'a t -> key -> 'a -> 'a t val find : 'a t -> key -> 'a val remove : 'a t -> key -> 'a t val mem : 'a t -> key -> bool val find_key : 'a t -> key -> key option val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val fold : ('a -> key -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold_map : ('a -> key -> 'b -> 'a * 'c) -> 'a -> 'b t -> 'a * 'c t val forall2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool val forall : (key -> 'a -> bool) -> 'a t -> bool val exists : (key -> 'a -> bool) -> 'a t -> bool val find_iter : (key -> 'a -> 'b option) -> 'a t -> 'b option val isect_mem : 'a t -> (key -> bool) -> 'a t val choose : 'a t -> key * 'a val filter_add : 'a t -> key -> ('a option -> 'a) -> 'a t val filter_remove : 'a t -> key -> ('a -> 'a option) -> 'a t val replace : 'a t -> key -> ('a -> 'a) -> 'a t val keys : 'a t -> key list val data : 'a t -> 'a list val add_list : 'a t -> (key * 'a) list -> 'a t val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val union : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t end omake-0.10.3/src/ir/omake_command_type.mli0000644000175000017500000000332013177364666017073 0ustar gerdgerdtype arg_string = | ArgString of string | ArgData of string type arg = arg_string list type command_digest = Digest.t option type command_flag = QuietFlag | AllowFailureFlag | AllowOutputFlag type ('exp, 'argv, 'value) poly_command_inst = CommandEval of 'exp list | CommandPipe of 'argv | CommandValues of 'value list type ('venv, 'exp, 'argv, 'value) poly_command_line = { command_loc : Lm_location.t; command_dir : Omake_node.Dir.t; command_target : Omake_node.Node.t; command_flags : command_flag list; command_venv : 'venv; command_inst : ('exp, 'argv, 'value) poly_command_inst; } val simple_string_of_arg : arg_string list -> string val glob_string_of_arg : Lm_glob.glob_options -> arg_string list -> string val is_glob_arg : Lm_glob.glob_options -> arg_string list -> bool val is_quoted_arg : arg_string list -> bool val pp_arg_data_string : string Lm_printf.t val pp_print_arg : arg_string list Lm_printf.t val pp_print_verbose_arg : arg_string list Lm_printf.t val pp_print_command_flag : command_flag Lm_printf.t val pp_print_command_flags : command_flag list Lm_printf.t module type PrintArgvSig = sig type argv val pp_print_argv : argv Lm_printf.t end module MakePrintCommand : functor (PrintArgv : PrintArgvSig) -> sig val pp_print_command_inst : (Omake_ir.exp, PrintArgv.argv, 'a) poly_command_inst Lm_printf.t val pp_print_command_line : ('a, Omake_ir.exp, PrintArgv.argv, 'b) poly_command_line Lm_printf.t val pp_print_command_lines : ('a, Omake_ir.exp, PrintArgv.argv, 'b) poly_command_line list Lm_printf.t end omake-0.10.3/src/ir/omake_ir_free_vars.mli0000644000175000017500000000057213177364666017070 0ustar gerdgerd(* Calculate the static free variables of an expression. *) type free_vars val free_vars_exp : Omake_ir.exp -> free_vars val free_vars_exp_list : Omake_ir.exp list -> free_vars (* * Operations on free var sets. *) val free_vars_empty : free_vars val free_vars_union : free_vars -> free_vars -> free_vars val free_vars_set : free_vars -> Omake_ir_util.VarInfoSet.t omake-0.10.3/src/ir/omake_ir_print.mli0000644000175000017500000000105713177364666016247 0ustar gerdgerd val pp_print_var_scope : Omake_ir.var_scope Lm_printf.t val pp_print_var_info : Omake_ir.var_info Lm_printf.t val pp_print_arity : Omake_ir.arity Lm_printf.t val pp_print_string_exp : Omake_ir.string_exp Lm_printf.t val pp_print_string_exp_list : Omake_ir.string_exp list Lm_printf.t val pp_print_exp : Omake_ir.exp Lm_printf.t val pp_print_exp_list : Omake_ir.exp list Lm_printf.t val pp_print_exp_list_simple : Omake_ir.exp list Lm_printf.t val pp_print_export_info : Omake_ir.export Lm_printf.t omake-0.10.3/src/ir/omake_command.mli0000644000175000017500000000167313177364666016043 0ustar gerdgerd(* * Argument parser. *) type arg_buffer val arg_buffer_empty : arg_buffer val arg_buffer_add_string : arg_buffer -> string -> arg_buffer val arg_buffer_add_data : arg_buffer -> string -> arg_buffer val arg_buffer_contents : arg_buffer -> Omake_command_type.arg_string list (* * Parse commands. *) val parse_commands : 'venv -> Omake_node.Dir.t -> Omake_node.Node.t -> Lm_location.t -> (Omake_command_type.command_flag list * ('exp, ('exe, 'arg_command, 'arg_apply, 'arg_other, 'apply) Omake_shell_type.poly_pipe, 'value) Omake_command_type.poly_command_inst) list -> ('venv, 'exp, ('exe, 'arg_command, 'arg_apply, 'arg_other, 'apply) Omake_shell_type.poly_pipe, 'value) Omake_command_type.poly_command_line list (* * Add the output flag. *) val command_allow_output : ('venv, 'exp, 'argv, 'value) Omake_command_type.poly_command_line -> ('venv, 'exp, 'argv, 'value) Omake_command_type.poly_command_line omake-0.10.3/src/ir/omake_install.mli0000644000175000017500000000010613177364666016061 0ustar gerdgerdval install_current : bool -> unit val install_subdirs : bool -> unit omake-0.10.3/src/ir/omake_options.mli0000644000175000017500000000560513177364666016117 0ustar gerdgerd(* * Options for the omake program. * *) (* * When to print output. *) type eval_flag = | EvalNever | EvalLazy | EvalEager (* * Diversion control. *) type output_flag = | OutputNormal | OutputPostponeSuccess | OutputPostponeError | OutputRepeatErrors (* * Make the default state explicit (the actual value may depend on the value of other settings). *) type setting type t = { job_count : int; remote_servers : (string * int) list; terminate_on_error : setting; dry_run : bool; print_command : eval_flag; print_dir : bool; print_file : bool; print_status : bool; print_exit : bool; mutable print_progress : setting; verbose : bool; touch_only : bool; flush_cache : bool; flush_dependencies : bool; print_dependencies : bool; show_dependencies : string list; all_dependencies : bool; verbose_dependencies : bool; cd_root : bool; project : bool; poll : setting; osh : bool; poll_on_done : bool; flush_include : bool; flush_static : bool; allow_exceptions : bool; absname : bool; output : (output_flag * bool) list; (* Warnings *) warn_declare : bool; warn_error : bool } (* * Initial options. *) val default_options : t (* * Argument specifier. *) val options_spec : (string * t Lm_arg.poly_spec * string) list val output_spec : (string * t Lm_arg.poly_spec * string) list (* * Parallel build options *) val opt_parallel : t -> bool val opt_job_count : t -> int val opt_remote_servers : t -> (string * int) list val opt_terminate_on_error : t -> bool val opt_poll : t -> bool val opt_poll_on_done : t -> bool val set_osh_opt : t -> t val opt_print_dir : t -> bool val opt_print_status : t -> bool val opt_print_exit : t -> bool val opt_print_progress : t -> bool val opt_touch_only : t -> bool val opt_flush_cache : t -> bool val opt_flush_dependencies : t -> bool val opt_all_dependencies : t -> bool val opt_verbose_dependencies : t -> bool val opt_cd_root : t -> bool val opt_project : t -> bool val opt_flush_include : t -> bool val opt_flush_static : t -> bool val opt_verbose : t -> bool val opt_print_command : t -> eval_flag val set_print_command_opt : t -> eval_flag -> t val opt_print_file : t -> bool val set_print_file_opt : t -> bool -> t val opt_absname : t -> bool val set_absname_opt : t -> bool -> t val opt_divert : t -> bool (* true when some --output-* diversions other than --output-normal are enabled *) val opt_output : t -> output_flag -> bool val opt_allow_exceptions : t -> bool val set_allow_exceptions_opt : t -> bool -> t val opt_warn_declare : t -> bool val opt_warn_error : t -> bool omake-0.10.3/src/ir/omake_var.mli0000644000175000017500000001075713177364666015220 0ustar gerdgerd(* * Variables. *) (* * Generally useful variables in pervasives. *) val explicit_target_var : Omake_ir.var_info val wild_var : Omake_ir.var_info val cwd_var : Omake_ir.var_info val stdlib_var : Omake_ir.var_info val stdroot_var : Omake_ir.var_info val ostype_var : Omake_ir.var_info val omakepath_var : Omake_ir.var_info val path_var : Omake_ir.var_info val auto_rehash_var : Omake_ir.var_info (* val printexitvalue_var : Omake_ir.var_info *) val system_var : Omake_ir.var_info val oshell_var : Omake_ir.var_info val cdpath_var : Omake_ir.var_info val history_file_var : Omake_ir.var_info val history_length_var : Omake_ir.var_info val targets_var : Omake_ir.var_info val build_summary_var : Omake_ir.var_info val prompt_var : Omake_ir.var_info val ignoreeof_var : Omake_ir.var_info val exit_on_uncaught_exception_var : Omake_ir.var_info val abort_on_command_error_var : Omake_ir.var_info val create_subdirs_var : Omake_ir.var_info val allow_empty_subdirs_var : Omake_ir.var_info val glob_options_var : Omake_ir.var_info val glob_ignore_var : Omake_ir.var_info val glob_allow_var : Omake_ir.var_info val scanner_mode_var : Omake_ir.var_info val stdin_var : Omake_ir.var_info val stdout_var : Omake_ir.var_info val stderr_var : Omake_ir.var_info val argv_var : Omake_ir.var_info val options_var : Omake_ir.var_info val star_var : Omake_ir.var_info val at_var : Omake_ir.var_info val gt_var : Omake_ir.var_info val plus_var : Omake_ir.var_info val hat_var : Omake_ir.var_info val lt_var : Omake_ir.var_info val amp_var : Omake_ir.var_info val braces_var : Omake_ir.var_info val parse_loc_var : Omake_ir.var_info val zero_var : Omake_ir.var_info val nf_var : Omake_ir.var_info val fs_var : Omake_ir.var_info val rs_var : Omake_ir.var_info val filename_var : Omake_ir.var_info val fnr_var : Omake_ir.var_info val object_var : Omake_ir.var_info val int_object_var : Omake_ir.var_info val float_object_var : Omake_ir.var_info val string_object_var : Omake_ir.var_info val sequence_object_var : Omake_ir.var_info val array_object_var : Omake_ir.var_info val fun_object_var : Omake_ir.var_info val rule_object_var : Omake_ir.var_info val file_object_var : Omake_ir.var_info val dir_object_var : Omake_ir.var_info val body_object_var : Omake_ir.var_info val in_channel_object_var : Omake_ir.var_info val out_channel_object_var : Omake_ir.var_info val in_out_channel_object_var : Omake_ir.var_info val lexer_object_var : Omake_ir.var_info val parser_object_var : Omake_ir.var_info val location_object_var : Omake_ir.var_info val map_object_var : Omake_ir.var_info val shell_object_var : Omake_ir.var_info val target_object_var : Omake_ir.var_info val stat_object_var : Omake_ir.var_info val passwd_object_var : Omake_ir.var_info val group_object_var : Omake_ir.var_info val pipe_object_var : Omake_ir.var_info val select_object_var : Omake_ir.var_info val runtime_exception_var : Omake_ir.var_info val var_object_var : Omake_ir.var_info val tm_object_var : Omake_ir.var_info val printexitvalue_var : Omake_ir.var_info val extends_var : Omake_ir.var_info val omakeflags_var : Omake_ir.var_info val omakeargv_var : Omake_ir.var_info (* * Internal fields. *) val loc_field_var : Omake_ir.var_info val builtin_field_var : Omake_ir.var_info val map_field_var : Omake_ir.var_info val current_prec_field_var : Omake_ir.var_info val lexer_field_var : Omake_ir.var_info val file_var : Omake_ir.var_info val file_id_var : Omake_ir.var_info (* * $0, $1, $2... *) val create_numeric_var : int -> Omake_ir.var_info omake-0.10.3/src/ir/omake_pos.mli0000644000175000017500000000157113177364666015223 0ustar gerdgerd open Omake_value_type module Make (Name : sig val name : string end) : sig val loc_exp_pos : Lm_location.t -> pos val loc_pos : Lm_location.t -> pos -> pos val ast_exp_pos : Omake_ast.exp -> pos val ir_exp_pos : Omake_ir.exp -> pos val var_exp_pos : Omake_ir.var -> pos val string_exp_pos : string -> pos val value_exp_pos : Omake_value_type.t -> pos val string_pos : string -> pos -> pos val pos_pos : pos -> pos -> pos val int_pos : int -> pos -> pos val var_pos : Omake_ir.var -> pos -> pos val error_pos : omake_error -> pos -> pos val del_pos : (Format.formatter -> unit) -> Lm_location.t -> pos val del_exp_pos : (Format.formatter -> unit) -> pos -> pos (* Utilities *) val loc_of_pos : pos -> Lm_location.t val pp_print_pos : pos Lm_printf.t end omake-0.10.3/src/ir/omake_node.mli0000644000175000017500000000435513177364666015352 0ustar gerdgerd(** This is the base part of the build system. Each file in the system is represented as a node. Node may be virtual: the node may exist before the file does. For each file, we maintain stat and MD5 information (if they exist). This case [in-]sensitivity of file names is a complex issue. We make the type abstract so we don't make a mistake. *) module Dir : Omake_node_sig.DirSig module DirSet : Lm_set_sig.LmSet with type elt = Dir.t module DirTable : Lm_map_sig.LmMap with type key = Dir.t module DirListHash : Lm_hash.HashMarshalSig with type elt = Dir.t list module DirListSet : Lm_set_sig.LmSet with type elt = DirListHash.t module DirListTable : Lm_map_sig.LmMap with type key = DirListHash.t module Node : Omake_node_sig.NodeSig with type dir = Dir.t module NodeSet : Lm_set_sig.LmSet with type elt = Node.t module NodeTable : Lm_map_sig.LmMap with type key = Node.t module NodeMTable : Lm_map_sig.LmMapList with type key = Node.t module PreNodeSet : Lm_set_sig.LmSet with type elt = Node.pre module Mount : Omake_node_sig.MountSig with type dir = Dir.t with type node = Node.t with type t = Node.mount;; type mount_info = Node.t Omake_node_sig.poly_mount_info val no_mount_info : mount_info (* * Handle known phonies. *) val create_node_or_phony : PreNodeSet.t -> mount_info -> Mount.t -> Omake_node_sig.phony_ok -> Dir.t -> string -> Node.t (* Same, but factor out the sometimes slow parser for phony names: *) type phony_name val parse_phony_name : string -> phony_name (* failsafe *) val create_node_or_phony_1 : PreNodeSet.t -> mount_info -> Mount.t -> Omake_node_sig.phony_ok -> Dir.t -> phony_name -> Node.t val node_will_be_phony : PreNodeSet.t -> Omake_node_sig.phony_ok -> Dir.t -> phony_name -> bool (* * For debugging. *) val pp_print_dir : Dir.t Lm_printf.t val pp_print_node : Node.t Lm_printf.t val pp_print_node_kind : Omake_node_sig.node_kind Lm_printf.t val pp_print_string_list : string list Lm_printf.t val pp_print_node_set : NodeSet.t Lm_printf.t val pp_print_node_list : Node.t list Lm_printf.t val pp_print_node_table : 'a NodeTable.t Lm_printf.t val pp_print_node_set_table : NodeSet.t NodeTable.t Lm_printf.t val pp_print_node_set_table_opt : NodeSet.t NodeTable.t option Lm_printf.t omake-0.10.3/src/ir/omake_cache.mli0000644000175000017500000001103113177364666015455 0ustar gerdgerd(* Cache information about past runs. *) (* Debugging *) val debug_cache : bool ref (* The abstract type for the cache database *) type t (* Keys for various functions *) type key (* Directory listing *) type dir_listing type exe_listing (* Manifest keys *) val scanner_fun : key val rule_fun : key val env_fun : key val include_fun : key val env_target : Omake_node.Node.t (* Fetch the cache *) val create : unit -> t val from_channel : Omake_options.t -> in_channel -> t val to_channel : Pervasives.out_channel -> t -> unit (* * Stats. *) val stats : t -> int * int (* * File digest information. * The reset functions indicate that stat info may need to be recomputed. * The stat functions get the digest. * The ?force flag, if set, forces the restat in case we cached a _negative_ * information on the file (file did not exist before). *) val stat : t -> Omake_node.Node.t -> Omake_cache_type.digest val stat_set : t -> Omake_node.NodeSet.t -> Omake_cache_type.digest Omake_node.NodeTable.t val stat_table : t -> 'b Omake_node.NodeTable.t -> Omake_cache_type.digest Omake_node.NodeTable.t val stat_unix : t -> ?force:bool -> ?follow_symlinks:bool -> Omake_node.Node.t -> Unix.LargeFile.stats val is_dir : t -> ?force:bool -> ?follow_symlinks:bool -> Omake_node.Node.t -> bool val reset : t -> Omake_node.Node.t -> unit val reset_set : t -> Omake_node.NodeSet.t -> unit val reset_table : t -> 'b Omake_node.NodeTable.t -> unit val force_stat : t -> Omake_node.Node.t -> Omake_cache_type.digest val force_stat_set : t -> Omake_node.NodeSet.t -> Omake_cache_type.digest Omake_node.NodeTable.t val force_stat_table : t -> 'b Omake_node.NodeTable.t -> Omake_cache_type.digest Omake_node.NodeTable.t val stat_changed : t -> Omake_node.Node.t -> bool val process_delayed_digests : t -> unit (* Run through the request queue, and compute the digests *) (* * Check if a file exists. *) val exists : t -> ?force:bool -> Omake_node.Node.t -> bool val exists_dir : t -> ?force:bool -> Omake_node.Dir.t -> bool (* * Directory listings. The Boolean in ls_path and ls_exe_path should * be true for those directory collections where auto-rehashing is to * be performed. *) val rehash : t -> unit val ls_dir : t -> bool -> Omake_node.Dir.t -> dir_listing val ls_path : t -> (bool * Omake_node.Dir.t list) list -> dir_listing val listing_find : t -> dir_listing -> string -> Omake_cache_type.dir_entry val ls_exe_path : t -> (bool * Omake_node.Dir.t list) list -> exe_listing val exe_find : t -> exe_listing -> string -> Omake_node.Node.t val exe_find_all : t -> exe_listing -> string -> Omake_node.Node.t list val exe_complete : t -> exe_listing -> string -> Lm_string_set.StringSet.t val exe_suffixes : string list (* * Memoizing commands. * * add : key targets sources commands result * up_to_date : key sources commands * find_result : key sources commands * find_result_sloppy : key target * * The sloppy function just returns the results for the target * without even considering the command and dependencies. *) val add : t -> key -> Omake_node.Node.t -> Omake_node.NodeSet.t -> Omake_node.NodeSet.t -> Omake_command_type.command_digest -> Omake_cache_type.memo_deps_result -> unit val up_to_date : t -> key -> Omake_node.NodeSet.t -> Omake_command_type.command_digest -> bool val up_to_date_status : t -> key -> Omake_node.NodeSet.t -> Omake_command_type.command_digest -> Omake_cache_type.memo_status val find_result : t -> key -> Omake_node.NodeSet.t -> Omake_command_type.command_digest -> Omake_cache_type.memo_deps val find_result_sloppy : t -> key -> Omake_node.Node.t -> Omake_cache_type.memo_deps (* * Similar functions for values. The bool flag indicates whether we want a static value. *) val find_value : t -> Omake_value_type.t -> bool -> Omake_node.NodeSet.t -> Omake_command_type.command_digest -> Omake_value_type.obj val add_value : t -> Omake_value_type.t -> bool -> Omake_node.NodeSet.t -> Omake_command_type.command_digest -> Omake_cache_type.memo_obj_result -> unit (* * Printing. *) val pp_print_digest : Omake_cache_type.digest Lm_printf.t val pp_print_node_digest_table : Omake_cache_type.digest Omake_node.NodeTable.t Lm_printf.t val pp_print_memo_result : Omake_node.NodeSet.t Omake_node.NodeTable.t Lm_printf.t -> Omake_cache_type.memo_deps_result Lm_printf.t omake-0.10.3/src/ir/omake_state.mli0000644000175000017500000000177313177364666015546 0ustar gerdgerd(* * Configuration. *) (* * Error codes for various actions. *) val signal_error_code : int val fork_error_code : int val internal_error_code : int val deadlock_error_code : int val exn_error_code : int val scanner_error_code : int (* * Name of the database. *) val db_name : string (* * Name of the makefiles. *) val makefile_name : string val makeroot_name : string val makeroot_short_name : string val omake_file_suffix : string (* * Cache management. *) val always_use_dotomake : bool ref val set_omake_dir : string -> unit (* * Files. *) val lib_dir : string val lib_dir_reason : string val home_dir : string val application_dir : string val omake_dir : unit -> string val db_file : unit -> string val history_file : unit -> string val omakeinit_file : string val omakerc_file : string val oshrc_file : string val get_cache_file : string -> string -> string * Unix.file_descr val lock_file : Unix.file_descr -> Unix.lock_command -> unit omake-0.10.3/src/front/0000755000175000017500000000000013177364666013255 5ustar gerdgerdomake-0.10.3/src/front/OMakefile0000644000175000017500000000026113177364665015032 0ustar gerdgerd OCAMLINCLUDES[] += ../libmojave FILES[] = lm_hash_cons lm_lexer lm_parser lm_glob MakeOCamlLibrary(frt, $(FILES)) clean: $(CLEAN) MakeMakefile() omake-0.10.3/src/front/lm_glob.ml0000644000175000017500000006441613177364665015234 0ustar gerdgerd(* * Glob expansion. * * There is a dilemma here for Win32. * Since \ is the pathname separator, we will * often see names like "dir\*.c". This is not * and escape sequence in the DOS shell, and in * fact * is not a valid character in Win32 * filenames. * * So, we could turn off escape sequences in Win32, * but doing this globally is a bad idea. For example, * what about the sequence dir\[a-z]*.c? In this case, * the [ and ] characters _are_ valid in Win32 filenames. * * For now, we punt. The \ character is considered to * be an escape character. If you want globbing in * Win32, use forward slashes. The result will still * use backslashes, so no worries. * *) (************************************************************************ * Tilde expansion. *) (* * Keep a table of entries. * Whenever we look a value in the passwd file, * add it to the table. *) let tilde_table = ref [||] (* * Keep the table sorted for quick lookup. *) let tilde_insert (dir : string) (name : string) = let table = !tilde_table in let len = Array.length table in if len = 0 then tilde_table := [|dir, name|] else (* Binary search *) let rec search i j (dir : string) table = if i < j - 1 then let k = (i + j) / 2 in let dir', _ = table.(k) in if dir' > dir then search i k dir table else search k j dir table else i in let i = search (-1) len dir table in if i >= 0 && fst table.(i) = dir then (if snd table.(i) <> "" then table.(i) <- dir, name) else let i = succ i in let ntable = Array.make (len + 1) table.(0) in Array.blit table 0 ntable 0 i; ntable.(i) <- dir, name; Array.blit table i ntable (i + 1) (len - i); tilde_table := ntable (* * Find an entry in the table. *) let rec tilde_matches dir1 dir2 len i = i = len || dir1.[i] = dir2.[i] && tilde_matches dir1 dir2 len (succ i) let tilde_collapse dir = let table = !tilde_table in let len = Array.length table in let rec search i j = if i < j - 1 then let k = (i + j) / 2 in let dir', _ = table.(k) in if dir' > dir then search i k else search k j else i in let i = search (-1) len in if i < 0 then dir else let dir', name = table.(i) in let len' = String.length dir' in let len = String.length dir in if len' <= len && tilde_matches dir' dir len' 0 then let namelen = String.length name in let length = len - len' + namelen + 1 in let s = Bytes.make length ' ' in Bytes.set s 0 '~'; Bytes.blit_string name 0 s 1 namelen; Bytes.blit_string dir len' s (namelen + 1) (len - len'); Bytes.to_string s else dir (* * Here is the caching getpwnam. *) let getpwnam user = let passwd = Unix.getpwnam user in let dir = passwd.Unix.pw_dir in tilde_insert dir user; dir let gethomedir = getpwnam (* * Try to figure out the home directory as best as possible. *) let home_dir = let home = Lm_unix_util.home_dir in tilde_insert home ""; home (* * Get a list of all the users. *) let getusers () = let users = Lm_unix_util.getpwents () in List.map (fun entry -> let { Unix.pw_name = name; Unix.pw_dir = dir; _ } = entry in tilde_insert dir name; name) users (************************************************************************ * Glob expansion. *) type glob_option = GlobNoBraces (* Do not perform csh-style brace expansion *) | GlobNoTilde (* Do not perform tilde-expansion *) | GlobNoEscape (* The \ character does not escape special characters *) | GlobNoCheck (* If an expansion fails, return the expansion literally *) | GlobIgnoreCheck (* If an expansion fails, it expands to nothing *) | GlobDot (* Allow wildcards to match filenames with a leading . *) | GlobOnlyFiles (* Return only non-directories in the result *) | GlobOnlyDirs (* Return only directories in the result *) | GlobCVSIgnore (* Ignore files as specified by .cvsignore files *) | GlobIgnore of string list (* Ignore the files that match the pattern *) | GlobAllow of string list (* Allow only files that match the pattern *) | GlobIgnoreFun of (string -> bool) (* Ignore the files specified by the function *) | GlobAllowFun of (string -> bool) (* Allow only the files specified by the function *) | GlobHomeDir of string (* Home directory for ~ expansion *) | GlobProperSubdirs (* Include only proper subdirs in listing *) type glob_check = | NoMatchError | NoMatchPreserve | NoMatchIgnore type glob_options = { glob_braces : bool; glob_tilde : bool; glob_escape : bool; glob_check : glob_check; glob_dot : bool; glob_files : bool; glob_dirs : bool; glob_cvs : bool; glob_ignore : (string -> bool); glob_allow : (string -> bool); glob_cvsignore : (string -> bool); glob_home : string; glob_proper : bool } let default_glob_options = { glob_braces = true; glob_tilde = true; glob_escape = true; glob_check = NoMatchError; glob_dot = false; glob_files = false; glob_dirs = false; glob_cvs = false; glob_ignore = (fun _ -> false); glob_allow = (fun _ -> true); glob_cvsignore = (fun _ -> false); glob_home = home_dir; glob_proper = false } (************************************************************************ * Utilities. *) (* * Determine if a string contains glob characters. *) let is_glob_string options name = let len = String.length name in let rec search lbrack i = if i >= len then false else match name.[i] with '*' | '?' -> true | '~' when i = 0 -> true | '[' -> search true (succ i) | ']' -> lbrack || search lbrack (succ i) | '\\' when options.glob_escape -> search lbrack (i + 2) | _ -> search lbrack (succ i) in search false 0 let glob_add_escaped options buf s = let len = String.length s in let rec collect i = if i < len then let c = String.unsafe_get s i in match c with '*' | '?' | '[' | ']' -> Buffer.add_char buf '\\'; Buffer.add_char buf c; collect (succ i) | '~' when i = 0 -> Buffer.add_char buf '\\'; Buffer.add_char buf c; collect (succ i) | '{' | '}' when options.glob_braces -> Buffer.add_char buf '\\'; Buffer.add_char buf c; collect (succ i) | '\\' when options.glob_escape -> Buffer.add_char buf '\\'; if i < len - 1 then begin Buffer.add_char buf s.[i + 1]; collect (i + 2) end | c -> Buffer.add_char buf c; collect (succ i) in collect 0 (* * Unescape a name. *) let unescape options s = if options.glob_escape then let len = String.length s in let buf = Buffer.create len in let rec collect i = if i = len then Buffer.contents buf else let c = s.[i] in if c = '\\' && i < len - 1 then let c = s.[i + 1] in match c with '*' | '?' | '[' | ']' | '~' | '{' | '}' -> Buffer.add_char buf c; collect (i + 2) | _ -> Buffer.add_char buf '\\'; collect (i + 1) else begin Buffer.add_char buf c; collect (i + 1) end in collect 0 else s (* * Don't add unnecessary separators. *) let filename_concat dir name = match dir, name with "", _ -> name | _, "" -> dir | _ -> Filename.concat dir name (* * Split the path into root part, and the rest. * If escaping is enabled, do not split at escape sequences, * but split everywhere else. *) let filename_split options s = let len = String.length s in let add_name names start i = if start < i then String.sub s start (i - start) :: names else names in let rec collect names start i = if i = len then add_name names start i else let c = s.[i] in match c with '/' -> collect (add_name names start i) (succ i) (succ i) | '\\' -> if options.glob_escape && i < len - 1 then let c = s.[i + 1] in match c with '*' | '?' | '[' | ']' | '~' -> collect names start (i + 2) | _ -> collect (add_name names start i) (succ i) (succ i) else collect (add_name names start i) (succ i) (succ i) | _ -> collect names start (succ i) in let names = collect [] 0 0 in List.rev names (* * Split the rest into parts. *) let filename_path options name : string list Lm_filename_util.path = match Lm_filename_util.filename_string name with AbsolutePath (root, path) -> Lm_filename_util.AbsolutePath (root, filename_split options path) | RelativePath path -> RelativePath (filename_split options path) (************************************************************************ * Shell regular expressions. * *) let add_shell_pattern options buf s = let len = String.length s in let rec collect i = if i >= len then Buffer.add_char buf '$' else let c = s.[i] in match s.[i] with '*' -> Buffer.add_string buf ".*"; collect (succ i) | '?' -> Buffer.add_string buf "."; collect (succ i) | '.' | '+' | '^' | '$' | '|' | '(' | ')' | '{' | '}' -> Buffer.add_char buf '\\'; Buffer.add_char buf c; collect (succ i) | '\\' -> if options.glob_escape && i < len - 1 then let c = s.[i + 1] in match c with '*' | '?' | '[' | ']' | '~' -> Buffer.add_char buf '\\'; Buffer.add_char buf c; collect (i + 2) | _ -> Buffer.add_string buf "\\\\"; collect (succ i) else begin Buffer.add_string buf "\\\\"; collect (succ i) end | _ -> Buffer.add_char buf c; collect (succ i) in collect 0 let add_shell_disjunct options buf s = Buffer.add_string buf "|"; add_shell_pattern options buf s let regexp_of_shell_pattern options s = let buf = Buffer.create 32 in add_shell_pattern options buf s; Lm_lexer.LmStr.regexp (Buffer.contents buf) let make_filter options sl default = let buf = Buffer.create 32 in match sl with s :: sl -> add_shell_pattern options buf s; List.iter (add_shell_disjunct options buf) sl; let pattern = Lm_lexer.LmStr.regexp (Buffer.contents buf) in (fun name -> Lm_lexer.LmStr.string_match pattern name 0) | [] -> (fun _ -> default) (* * These are the files that CVS ignores by default. * https://www.cvshome.org/docs/manual/cvs-1.11.16/cvs_18.html#IDX266 *) let default_patterns = ["RCS"; "SCCS"; "CVS"; "CVS.adm"; "RCSLOG"; "cvslog.*"; "tags"; "TAGS"; ".make.state"; ".nse_depinfo"; ".svn"; "*~"; "#*"; ".#*"; ",*"; "_$*"; "*$"; "*.old"; "*.bak"; "*.BAK"; "*.orig"; "*.rej"; ".del-*"; "*.a"; "*.olb"; "*.o"; "*.obj"; "*.so"; "*.exe"; "*.Z"; "*.elc"; "*.ln"; "core.*"] let stdignore = let buf = Buffer.create 256 in Buffer.add_string buf "^\\.cvsignore$"; List.iter (add_shell_disjunct default_glob_options buf) default_patterns; Lm_lexer.LmStr.regexp (Buffer.contents buf) (* * Load the ignore expression from .cvsignore. *) let load_cvsignore dirname = let filename = filename_concat dirname ".cvsignore" in (* Get the patterns from the file *) let inx = open_in filename in let rec collect patterns = try collect (Lm_string_util.tokens_std (input_line inx) @ patterns) with End_of_file -> patterns in let patterns = collect [] in let () = close_in inx in (* Concatenate them into a large regular expression *) let buf = Buffer.create 256 in Buffer.add_string buf "^\\.cvsignore$"; List.iter (add_shell_disjunct default_glob_options buf) default_patterns; List.iter (add_shell_disjunct default_glob_options buf) patterns; Lm_lexer.LmStr.regexp (Buffer.contents buf) let load_cvsignore dirname = let pattern = try load_cvsignore dirname with Sys_error _ -> stdignore in (fun name -> Lm_lexer.LmStr.string_match pattern name 0) (* * Check if a filename refers to a directory. *) let is_dir filename = try (Unix.lstat filename).Unix.st_kind = Unix.S_DIR with Unix.Unix_error _ -> false (************************************************************************ * Globbing. *) (* * Collect glob options. *) let create_options l = let rec collect options l = match l with option :: l -> let options = match option with GlobNoBraces -> { options with glob_braces = false } | GlobNoTilde -> { options with glob_tilde = false } | GlobNoEscape -> { options with glob_escape = false } | GlobNoCheck -> { options with glob_check = NoMatchPreserve } | GlobIgnoreCheck -> { options with glob_check = NoMatchIgnore } | GlobDot -> { options with glob_dot = true } | GlobOnlyFiles -> { options with glob_files = true } | GlobOnlyDirs -> { options with glob_dirs = true } | GlobCVSIgnore -> { options with glob_cvs = true } | GlobIgnoreFun f -> { options with glob_ignore = f } | GlobAllowFun f -> { options with glob_allow = f } | GlobIgnore sl -> { options with glob_ignore = make_filter options sl false } | GlobAllow sl -> { options with glob_allow = make_filter options sl true } | GlobHomeDir dir -> { options with glob_home = dir } | GlobProperSubdirs -> { options with glob_proper = true } in collect options l | [] -> options in collect default_glob_options l (* * Perform brace expansion. *) let rec expand_braces options expanded_names unexpanded_names = match unexpanded_names with name :: unexpanded_names -> let len = String.length name in let expanded_names, unexpanded_names = (* Search for the first brace *) let rec search_brace i = if i >= len then name :: expanded_names, unexpanded_names else match name.[i] with '\\' when options.glob_escape -> search_brace (i + 2) | '{' -> search_found 0 i (i + 1) [] (i + 1) | _ -> search_brace (i + 1) (* Found a brace, search for the parts *) and search_found level start last names i = if i >= len then raise (Failure (name ^ ": brace mismatch")); match name.[i] with '\\' when options.glob_escape -> search_found level start last names (i + 2) | ',' when level = 0 -> let name = String.sub name last (i - last) in search_found level start (i + 1) (name :: names) (i + 1) | '{' -> search_found (succ level) start last names (i + 1) | '}' when level = 0 -> let pref = String.sub name 0 start in let suf = String.sub name (i + 1) (len - i - 1) in let name = String.sub name last (i - last) in let names = name :: names in let names = List.map (fun s -> pref ^ s ^ suf) names in expanded_names, List.append names unexpanded_names | '}' -> search_found (pred level) start last names (i + 1) | _ -> search_found level start last names (i + 1) in search_brace 0 in expand_braces options expanded_names unexpanded_names | [] -> expanded_names let glob_braces options names = if options.glob_braces then expand_braces options [] (List.rev names) else names (* * Expand a glob pattern. * The dir is a fully-expanded directory name. *) let glob_dir_pattern options root dirs names dir pattern = let options = if options.glob_cvs then { options with glob_cvsignore = load_cvsignore dir } else options in let root_dir = filename_concat root dir in let dirx = Unix.opendir root_dir in let rec collect dirs names = let name = try Some (Unix.readdir dirx) with End_of_file -> None in match name with None -> dirs, names | Some "" | Some "." | Some ".." -> collect dirs names | Some name -> let root_name = filename_concat root_dir name in let file_name = filename_concat dir name in let dir_flag = is_dir root_name in let dirs, names = if (options.glob_dot || name.[0] <> '.') && (not options.glob_files || not dir_flag) && (not options.glob_dirs || dir_flag) && Lm_lexer.LmStr.string_match pattern name 0 && not (options.glob_ignore name) && (options.glob_allow name) && not (options.glob_cvsignore name) then if dir_flag then file_name :: dirs, names else dirs, file_name :: names else dirs, names in collect dirs names in let dirs_names = collect dirs names in Unix.closedir dirx; dirs_names let glob_dirs_pattern options root dirs pattern = let rec collect dirs' names' dirs = match dirs with dir :: dirs -> let dirs', names' = glob_dir_pattern options root dirs' names' dir pattern in collect dirs' names' dirs | [] -> dirs', names' in collect [] [] dirs let glob_dirs_name options root dirs name = if is_glob_string options name then let options = if name <> "" && name.[0] = '.' then { options with glob_dot = true } else options in let pattern = regexp_of_shell_pattern options name in glob_dirs_pattern options root dirs pattern else let name = unescape options name in List.fold_left (fun (dirs, names) dir -> let root_dir = filename_concat root dir in let root_name = filename_concat root_dir name in let file_name = filename_concat dir name in try let stat = Unix.LargeFile.stat root_name in if stat.Unix.LargeFile.st_kind = Unix.S_DIR then file_name :: dirs, names else dirs, file_name :: names with Unix.Unix_error _ -> dirs, names) ([], []) dirs (* * Perform tilde expansion. *) let null_root = "" let glob_tilde options root dir path = if options.glob_tilde then match path with name :: rest -> let len = String.length name in if len > 0 && name.[0] = '~' then if len = 1 then null_root, options.glob_home, rest else let user = String.sub name 1 (len - 1) in let dir = try getpwnam user with Not_found -> raise (Failure ("Unknown user: " ^ user)) in null_root, dir, rest else if len > 1 && name.[0] = '\\' && name.[1] = '~' then root, dir, String.sub name 1 (len - 1) :: rest else root, dir, path | [] -> root, dir, path else root, dir, path (* * Perform a glob expansion on a single path. *) let glob_match options root dir name = (* Split the path into components *) let root, dir, path = match filename_path options name with RelativePath path -> root, dir, path | AbsolutePath (root, path) -> null_root, Lm_filename_util.string_of_root root, path in (* Do ~ expansion *) let root, dir, path = glob_tilde options root dir path in (* Walk through the path *) let rec glob dirs path = match path with [] -> dirs, [] | [name] -> glob_dirs_name options root dirs name | name :: path -> let options = { options with glob_dirs = true } in let dirs, _ = glob_dirs_name options root dirs name in glob dirs path in glob [dir] path (* * Don't glob-expand unless it is a glob pattern. *) let glob_name options root dir name = if is_glob_string options name then let dirs, names = glob_match options root dir name in if dirs = [] && names = [] then match options.glob_check with NoMatchError -> raise (Failure (name ^ ": bad match")) | NoMatchPreserve -> [], [name] | NoMatchIgnore -> [], [] else dirs, names else if Filename.is_relative name then let name = unescape options name in let root_dir = filename_concat root dir in let root_name = filename_concat root_dir name in let file_name = filename_concat dir name in if is_dir root_name then [file_name], [] else [], [file_name] else let file_name = unescape options name in if is_dir file_name then [file_name], [] else [], [file_name] (* * Perform the actual glob. *) let glob options dir names = let names = glob_braces options names in List.fold_left (fun (dirs, names) name -> let dirs', names' = glob_name options dir "" name in let dirs = List.rev_append dirs' dirs in let names = List.rev_append names' names in dirs, names) ([], []) names (* * Don't glob-expand unless it is a glob pattern. * For argv expansion, we don't care about what is a directory * and what is not. *) let glob_argv_name options root dir name = if is_glob_string options name then let dirs, names = glob_match options root dir name in if dirs = [] then if names = [] then match options.glob_check with NoMatchError -> raise (Failure (name ^ ": bad match")) | NoMatchPreserve -> [name] | NoMatchIgnore -> [] else names else if names = [] then dirs else let names = List.append dirs names in List.sort Pervasives.compare names else let name = unescape options name in let file_name = filename_concat dir name in [file_name] (* * Glob an argv list. * We have to be a little more careful to preserve the order. *) let glob_argv options dir names = let names = glob_braces options names in let names = List.fold_left (fun names name -> let names' = glob_argv_name options dir "" name in List.rev_append names' names) [] names in List.rev names (************************************************************************ * Directory listings. *) (* * Get all the names in the directory. *) let list_dir_exn options root hidden_dirs dirs names dirname = let inx = Unix.opendir (filename_concat root dirname) in let rec read hidden_dirs dirs names = let name = try Some (Unix.readdir inx) with End_of_file -> None in match name with Some "." | Some ".." -> read hidden_dirs dirs names | None -> hidden_dirs, dirs, names | Some name -> let hidden_dirs, dirs, names = let filename = filename_concat dirname name in let dir_flag = is_dir filename in if (options.glob_dot || name.[0] <> '.') && (dir_flag || not options.glob_dirs) && not (options.glob_ignore name) && not (options.glob_cvsignore name) then if dir_flag then if options.glob_allow name then hidden_dirs, filename :: dirs, names else filename :: hidden_dirs, dirs, names else if options.glob_allow name then hidden_dirs, dirs, filename :: names else hidden_dirs, dirs, names else hidden_dirs, dirs, names in read hidden_dirs dirs names in let hidden_dirs_names = read hidden_dirs dirs names in Unix.closedir inx; hidden_dirs_names let list_dir_aux options root hidden_dirs dirs names dirname = let options = if options.glob_cvs then { options with glob_cvsignore = load_cvsignore (filename_concat root dirname) } else options in try list_dir_exn options root hidden_dirs dirs names dirname with Unix.Unix_error _ | Sys_error _ | Failure _ -> hidden_dirs, dirs, names (* * Perform a directory listing. *) let list_dirs options root dirs = let rec collect dirs names l = match l with dir :: l -> let _, dirs, names = list_dir_aux options root [] dirs names dir in collect dirs names l | [] -> dirs, names in collect [] [] dirs (* * Recursive directory listing. *) let list_dirs_rec options root dirs = let rec collect examined_dirs hidden_dirs unexamined_dirs names = match hidden_dirs, unexamined_dirs with dir :: hidden_dirs, _ -> let hidden_dirs, unexamined_dirs, names = list_dir_aux options root hidden_dirs unexamined_dirs names dir in collect examined_dirs hidden_dirs unexamined_dirs names | [], dir :: unexamined_dirs -> let examined_dirs = dir :: examined_dirs in let hidden_dirs, unexamined_dirs, names = list_dir_aux options root hidden_dirs unexamined_dirs names dir in collect examined_dirs hidden_dirs unexamined_dirs names | [], [] -> examined_dirs, names in let hidden_dirs, unexamined_dirs = List.fold_left (fun (hidden_dirs, unexamined_dirs) dir -> if options.glob_allow dir then hidden_dirs, dir :: unexamined_dirs else dir :: hidden_dirs, unexamined_dirs) ([], []) dirs in collect [] hidden_dirs unexamined_dirs [] (* * Recursively expand all subdirectories. *) let subdirs_of_dirs options root dirs = let options = { options with glob_dirs = true } in let rec collect listing hidden_dirs dirs = match hidden_dirs, dirs with dir :: hidden_dirs, _ -> let hidden_dirs, dirs, _ = list_dir_aux options root hidden_dirs dirs [] dir in collect listing hidden_dirs dirs | [], dir :: dirs -> let listing = dir :: listing in let hidden_dirs, dirs, _ = list_dir_aux options root hidden_dirs dirs [] dir in collect listing hidden_dirs dirs | [], [] -> listing in let hidden_dirs, dirs = if options.glob_proper then dirs, [] else [], dirs in collect [] hidden_dirs dirs (* * Regular expression export. *) let regex_of_shell_pattern = regexp_of_shell_pattern omake-0.10.3/src/front/lm_lexer.ml0000644000175000017500000025655413177364665015436 0ustar gerdgerdlet debug_lex = Lm_debug.create_debug (**) { debug_name = "lex"; debug_description = "Debug the lexer"; debug_value = false } let debug_lexgen = Lm_debug.create_debug (**) { debug_name = "lexgen"; debug_description = "Debug the lexer generator"; debug_value = false } (* * We simulate the NFA using the normal subset construction. * That is, the state of the DFA is a set of states of the NFA. * * In addition, we have counters for the r{n,m} regular expressions. * * So, we model a state of the NFA as a state and the list of * counters. A state of the DFA is a sorted list of NFA states. *) module NfaStateCore = struct type t = int * int list (* * Reset one of the counters. *) let rec reset_counter counters i = match counters with | counter :: counters -> if i = 0 then 0 :: counters else counter :: reset_counter counters (pred i) | [] -> raise (Invalid_argument "reset_counter: illegal counter") (* * Increment one of the counters. * Return the new counter value too. *) let incr_counter counters i min final max start = let rec incr counters i = match counters with counter :: counters -> if i = 0 then let counter = succ counter in counter, counter :: counters else let i, counters = incr counters (pred i) in i, counter :: counters | [] -> raise (Invalid_argument "incr_counter: illegal counter") in let counter, counters' = incr counters i in if counter < min then [start, counters'] else if counter = min then [final, counters'; start, counters'] else if max >= min && counter > max then [] else if max < min then (* This is an optimization: no need to increment the counter *) [final, counters; start, counters] else [final, counters'; start, counters'] end;; (* * Hash them. *) module NfaStateArg = struct type t = NfaStateCore.t let debug = "NfaState" let hash (s, counters) = Lm_hash_code.hash_int_list (s lxor 0x2c18c4d5) counters let rec compare_int_list (l1 : int list) (l2 : int list) = match l1, l2 with | i1 :: l1, i2 :: l2 -> if i1 < i2 then -1 else if i1 > i2 then 1 else compare_int_list l1 l2 | [], _ ::_ -> -1 | _ :: _, [] -> 1 | [], [] -> 0 let compare ((s1, counters1) : t) ((s2, counters2) : t) = if s1 < s2 then -1 else if s1 > s2 then 1 else compare_int_list counters1 counters2 end;; module NfaState = Lm_hash_cons.Make (NfaStateArg);; module NfaStateSet = Lm_set.LmMake (NfaState);; module NfaStateTable = Lm_map.LmMake (NfaState);; (* * DFA states. *) module DfaStateCore = struct type t = NfaState.t list (* Sorted *) (* * Empty set. *) let empty = ([] : t) (* * Membership. *) let mem (set : t) (state : NfaState.t) = List.mem state set (* * Add an element to the set. *) let rec add (set : t) (state : NfaState.t) = match set with j :: s -> if j > state then state :: set else if j = state then set else j :: add s state | [] -> [state] (* * Union of two sets. *) (* let rec union (s1 : t) (s2 : t) = *) (* match s1, s2 with *) (* i1 :: l1, i2 :: l2 -> *) (* if i1 = i2 then *) (* i1 :: union l1 l2 *) (* else if i1 < i2 then *) (* i1 :: union l1 s2 *) (* else *) (* i2 :: union s1 l2 *) (* | _, [] -> *) (* s1 *) (* | [], _ -> *) (* s2 *) end;; module DfaStateArg = struct type t = DfaStateCore.t let debug = "DfaState" let hash state = let buf = Lm_hash_code.HashCode.create () in Lm_hash_code.HashCode.add_int buf 0x0affb3d4; List.iter (fun state -> Lm_hash_code.HashCode.add_int buf (NfaState.hash state)) state; Lm_hash_code.HashCode.code buf let rec compare l1 l2 = match l1, l2 with state1 :: l1, state2 :: l2 -> let cmp = NfaState.compare state1 state2 in if cmp = 0 then compare l1 l2 else cmp | [], _ :: _ -> -1 | _ :: _, [] -> 1 | [], [] -> 0 end;; module DfaState = Lm_hash_cons.Make (DfaStateArg);; module DfaStateTable = Lm_map.LmMake (DfaState);; module IntCompare = struct type t = int let compare = (-) end module IntSet = Lm_set.LmMake (IntCompare);; module IntTable = Lm_map.LmMake (IntCompare);; (* * A argument has two parts. *) type arg = ArgLeft of int | ArgRight of int | ArgSearch module ArgCompare = struct type t = arg let compare a1 a2 = match a1, a2 with ArgLeft i1, ArgLeft i2 | ArgRight i1, ArgRight i2 -> if i1 < i2 then -1 else if i1 > i2 then 1 else 0 | ArgSearch, ArgSearch -> 0 | ArgLeft _, ArgRight _ | ArgLeft _, ArgSearch | ArgRight _, ArgSearch -> -1 | ArgSearch, ArgRight _ | ArgSearch, ArgLeft _ | ArgRight _, ArgLeft _ -> 1 end;; module ArgTable = Lm_map.LmMake (ArgCompare);; (* * A TransTable represents the transition function for a DFA. * We represent this as a sorted array of entries. *) (* * Binary search returns the smallest element * that is no smaller than the key. *) let rec binary_search table (key : int) i j = if i < j - 1 then let k = (i + j) lsr 1 in let key', _ = table.(k) in if key' < key then binary_search table key k j else binary_search table key i k else j module TransTable = struct type 'a t = (int * 'a) array let empty = [||] (* * Find an entry in the table, * returning the default value if not found. *) let find table key default = let len = Array.length table in let i = binary_search table key (-1) len in if i = len then default else let key', value = table.(i) in if key' = key then value else default (* * Add an entry to the table. * Assumes the entry does not already exist. *) let add table key value = let len = Array.length table in if len = 0 then [|key, value|] else let i = binary_search table key (-1) len in let new_array = Array.make (len + 1) (key, value) in Array.blit table 0 new_array 0 i; Array.blit table i new_array (i + 1) (len - i); new_array end (************************************************************************ * Lexer construction. *) (* * Argument types. *) module type LexerInput = sig (* * Input channel is a stream of integers. * Usually these are just the ASCII codes for characters. *) type t (* * The channel has two special characters. * bof: the beginning of file * eof: the end of file. *) val bof : int val eof : int (* * The next function returns the next character in the input stream. *) val lex_next : t -> int (* * The pos function returns the current position of * the input buffer within the lexeme * (used for collecting \( ... \) arguments). *) val lex_pos : t -> int (* * The lexer will call start when it begins lexing. * The integer should be the *previous* character in the * input channel, or bof if at the beginning. *) val lex_start : t -> int (* * In some cases, the lexer may want to restart scanning * from a previous point. If so, it will call this function * to reset the start point. *) val lex_restart : t -> int -> unit (* * When the lexer is done, it calls lex_stop with * the number of characters in the final lexeme. Note * that this can cause data to be pushed back onto the input stream. *) val lex_stop : t -> int -> unit (* * Before calling lex_stop, the lexer may ask for the * lexeme as a string. The integer is the number of * characters in the lexeme, the same as the argument * to lex_stop. *) val lex_string : t -> int -> string val lex_substring : t -> int -> int -> string val lex_loc : t -> int -> Lm_location.t end module type LexerAction = sig (* * Semantic actions. * Values of action type *must* be comparable with =, * hopefully quickly. * * For example, functions are not allowed. * If you want a function, you should make an array of functions, * and use the index for the action name. *) type action (* For debugging *) val pp_print_action : action Lm_printf.t (* For creating sets and tables *) val hash : action -> int val compare : action -> action -> int (* * You can use the function to decide which clauses take * precedence for a match of equal length. The function * gets two clause numbers. If you use the min function, * then you get the first clause that matched. If you * use the max function, you get the second clause that * matched. *) val choose : int -> int -> int end module MakeLexer (Input : LexerInput) (Action : LexerAction) = struct open Action (* * For now, just create a default action set. *) module ActionCompare = struct type t = action let compare = Action.compare end module ActionSet = Lm_set.LmMake (ActionCompare);; (************************************************************************ * Types. *) (* * A simplified regular expression. *) (* %%MAGICBEGIN%% *) type regex = RegexAnySymbol | RegexSymbol of IntSet.t | RegexExceptSymbol of IntSet.t | RegexLimitPrev of IntSet.t | RegexLimitNext of IntSet.t | RegexChoice of regex list | RegexSequence of regex list | RegexStar of regex | RegexPlus of regex | RegexInterval of regex * int * int (* regex, min, max *) | RegexArg of regex (* * Termination symbols. *) type regex_term = RegexTermEof | RegexTermRightParen of int | RegexTermRightArg of int | RegexTermPipe of int (* * An expression is nearly an NFA, * but designed to be built incrementally. * The id is an arbitrary int, but all clauses * must have unique ids. *) type exp = { exp_clauses : (action * int * regex) list; exp_id : int } (* * An action specifies: * ActionEpsilon state : epsilon transition to the given states * ActionArgStart i : start collecting the arguments for the rules * ActionArgStop i : stop collecting the arguments for the rules * ActionStop i : rule i is finished * ActionSymbol table : transition function * ActionLimit syms : normally an epsilon transition, but limited to syms * (this is to handle \< and \> symbols) *) type nfa_action = NfaActionEpsilon of int list (* next state list *) | NfaActionArgStart of int * int (* arg id, next state *) | NfaActionArgStop of int * int (* arg id, next state *) | NfaActionArgSearch of int (* next state *) | NfaActionStop of int (* clause id, next state *) | NfaActionSymbol of IntSet.t * int (* symbols, next state *) | NfaActionAnySymbol of int (* next state *) | NfaActionExceptSymbol of IntSet.t * int (* symbols, next state *) | NfaActionLimitPrev of IntSet.t * int (* symbols, next state *) | NfaActionLimitNext of IntSet.t * int (* symbols, next state *) | NfaActionNone | NfaActionResetCounter of int * int list (* counter, next state list *) | NfaActionIncrCounter of int * int * int * int * int (* counter, min, final, max, restart *) (* * This is the info we accumulate during compilation. * nfa_index : the index of the next state to be allocated * nfa_counter : the total number of interval expression we have seen * nfa_arg_index : the identifier of the next argument *) type nfa_accum = { nfa_index : int; nfa_counter : int; nfa_arg_index : int } (* * This is the info we pass left-to-right during compilation. * nfa_clause : the index of the current clause being compiled * nfa_arg_number : the index of the next argument *) type nfa_info = { nfa_clause : int; nfa_arg_number : int } (* * A state in the machine. *) type nfa_state = { nfa_state_index : int; nfa_state_action : nfa_action } type group_info = int * int (* GS: In the NFA and DFA, the groups are globally numbered, across all clauses. This pair [(offset,length)] selects the [length] number of global groups starting at [offset]. *) (* * The NFA has a start state, * and an array of states. *) type nfa = { nfa_hash : NfaState.state; nfa_actions : (action * group_info) IntTable.t; nfa_start : NfaState.t; nfa_search_start : NfaState.t; nfa_search_states : NfaStateSet.t; nfa_table : nfa_state array; nfa_args : IntSet.t IntTable.t } (* * DFA actions. The action include looking for final states * (the dfa_action_final field), as well as argument actions. * * The argument actions happen on the NfaState.t components of * the DFA state. The action table gives the actions that must * be performed for each NFA component that is the *target* * of the transition. * * Invariant: there is an entry in the dfa_action_parts for each * NFA component of the state that is the target of the transition. *) type dfa_action_inst = DfaActionArgStart of int | DfaActionArgStop of int | DfaActionArgSearch type dfa_action_arg = { dfa_action_off : int; dfa_action_inst : dfa_action_inst } type dfa_action = { dfa_action_src : NfaState.t; dfa_action_args : dfa_action_arg list } type dfa_actions = { dfa_action_final : (int * NfaState.t) option; (* clause id, NFA state *) dfa_action_actions : dfa_action NfaStateTable.t (* Actions for each of the target NFA components *) } (* * A transition may specify a new state and some actions. * or it may not exist, * or it may be unknown. *) type dfa_transition = DfaTransition of int * dfa_actions | DfaNoTransition | DfaUnknownTransition (* * A DFA state has an index, * the subset of states for the NFA, * and a lazy transition function. *) type dfa_state = { dfa_state_index : int; dfa_state_set : DfaState.t; mutable dfa_state_delta : dfa_transition TransTable.t } (* * The DFA has: *) type dfa = { mutable dfa_states : dfa_state array; (* May be partially filled *) mutable dfa_length : int; (* Index of the largest valid state *) mutable dfa_map : int DfaStateTable.t; (* Map from NFA state subsets to DFA states *) dfa_table : nfa_state array; (* The NFA *) dfa_action_table : (action * group_info) IntTable.t; (* The map from clause id to actions *) dfa_search_states : NfaStateSet.t; (* Set of states for searching *) dfa_nfa_hash : NfaState.state; (* HashCons table for NFA states *) dfa_dfa_hash : DfaState.state (* HashCons table for DFA states *) } (* * The actual type. *) type t = { lex_exp : exp; mutable lex_dfa : dfa option } (* %%MAGICEND%% *) (* * The pre-action is a partial action computation before * the complete action is collected. *) type pre_action = { pre_action_final : int option; (* clause id *) pre_action_args : dfa_action_arg list } (* * When we are scanning, we also have state. *) type dfa_info = { mutable dfa_stop_clause : int; (* Clause id of the last match, or 0 if none *) mutable dfa_stop_pos : int; (* Position of the last match *) mutable dfa_stop_args : int ArgTable.t; (* Arguments in the final state *) mutable dfa_start_pos : int; (* Starting position *) (* The current argument state *) mutable dfa_args : int ArgTable.t NfaStateTable.t; (* * The channel we are scanning from. *) dfa_channel : Input.t } (* Return values from the searchto function *) type searchto_info = LexEOF | LexSkipped of Lm_location.t * string | LexMatched of action * Lm_location.t * string * string * string list (************************************************************************ * Characters and classes. *) let bof = Input.bof let eof = Input.eof let zero_char = Char.code '0' let at_char = Char.code '@' let alert_char = Char.code 'G' - at_char let backspace_char = Char.code 'H' - at_char let formfeed_char = Char.code 'L' - at_char let newline_char = Char.code '\n' let cr_char = Char.code '\r' let tab_char = Char.code '\t' let vertical_tab_char = Char.code 'K' - at_char let hex_a_char = Char.code 'a' - 10 let hex_A_char = Char.code 'A' - 10 let alert_chars = IntSet.singleton alert_char let backspace_chars = IntSet.singleton backspace_char let formfeed_chars = IntSet.singleton formfeed_char let newline_chars = IntSet.singleton newline_char let cr_chars = IntSet.singleton cr_char let tab_chars = IntSet.singleton tab_char let vertical_tab_chars = IntSet.singleton vertical_tab_char (* * Character sets. *) external omake_alnum : unit -> string = "omake_alnum" external omake_alpha : unit -> string = "omake_alpha" external omake_graph : unit -> string = "omake_graph" external omake_lower : unit -> string = "omake_lower" external omake_upper : unit -> string = "omake_upper" external omake_punct : unit -> string = "omake_punct" external omake_space : unit -> string = "omake_space" let singleton_char c = IntSet.singleton (Char.code c) let explode_chars_add chars s = let len = String.length s in let rec collect chars i = if i = len then chars else collect (IntSet.add chars (Char.code s.[i])) (succ i) in collect chars 0 let explode_chars s = explode_chars_add IntSet.empty s let bof_char = IntSet.singleton bof let eof_char = IntSet.singleton eof let bof_chars s = explode_chars_add bof_char s let eof_chars s = explode_chars_add eof_char s let alnum_chars = explode_chars (omake_alnum ()) let alpha_chars = explode_chars (omake_alpha ()) let graph_chars = explode_chars (omake_graph ()) let lower_chars = explode_chars (omake_lower ()) let upper_chars = explode_chars (omake_upper ()) let punct_chars = explode_chars (omake_punct ()) let space_chars = explode_chars (omake_space ()) let blank_chars = explode_chars " \t" let cntrl_chars = let rec collect chars i = if i != 32 then collect (IntSet.add chars i) (succ i) else chars in collect IntSet.empty 0 let digit_chars = explode_chars "01234565789" let print_chars = IntSet.add graph_chars (Char.code ' ') let xdigit_chars = explode_chars_add digit_chars "abcdefABCDEF" (* let white_or_bof_chars = IntSet.add space_chars bof *) (* let white_or_eof_chars = IntSet.add space_chars eof *) let word_chars = IntSet.add alnum_chars (Char.code '_') let all_chars = let rec collect chars i = if i != 256 then collect (IntSet.add chars i) (succ i) else chars in collect IntSet.empty 0 let invert_chars chars = IntSet.diff all_chars chars let nonword_chars = invert_chars word_chars let bof_or_nonword_chars = IntSet.add nonword_chars bof let eof_or_nonword_chars = IntSet.add nonword_chars eof (************************************************************************ * Regular expressions. *) (* * Printer. *) let pp_print_char buf c = if c = bof then Lm_printf.pp_print_string buf "\\bof" else if c = eof then Lm_printf.pp_print_string buf "\\eof" else if c < 32 || c >= 127 then Format.fprintf buf "\\%03d" c else Lm_printf.pp_print_char buf (Char.chr c) let pp_print_chars buf cl = IntSet.iter (pp_print_char buf) cl let rec pp_print_regex buf regex = match regex with | RegexAnySymbol -> Lm_printf.pp_print_string buf "." | RegexSymbol cl -> Format.fprintf buf "(symbol "; IntSet.iter (fun c -> pp_print_char buf c) cl; Format.fprintf buf ")" | RegexExceptSymbol cl -> Format.fprintf buf "(^symbol "; IntSet.iter (fun c -> pp_print_char buf c) cl; Format.fprintf buf ")" | RegexLimitPrev cl -> Format.fprintf buf "(prev-symbol "; IntSet.iter (fun c -> pp_print_char buf c) cl; Format.fprintf buf ")" | RegexLimitNext cl -> Format.fprintf buf "(next-symbol "; IntSet.iter (fun c -> pp_print_char buf c) cl; Format.fprintf buf ")" | RegexChoice el -> Format.fprintf buf "@[(choice"; List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_regex e) el; Format.fprintf buf ")@]" | RegexSequence el -> Format.fprintf buf "@[(sequence"; List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_regex e) el; Format.fprintf buf ")@]" | RegexStar e -> Format.fprintf buf "(star %a)" pp_print_regex e | RegexPlus e -> Format.fprintf buf "(plus %a)" pp_print_regex e | RegexInterval (e, min, max) -> Format.fprintf buf "@[(interval{%d,%d}@ %a)@]" min max pp_print_regex e | RegexArg e -> Format.fprintf buf "@[\\(%a\\)@]" pp_print_regex e (* * Standard regular expressions. *) let left_word_delimiter = RegexSequence [RegexLimitPrev bof_or_nonword_chars; RegexLimitNext word_chars] let right_word_delimiter = RegexSequence [RegexLimitPrev word_chars; RegexLimitNext eof_or_nonword_chars] let word_delimiter = RegexChoice [left_word_delimiter; right_word_delimiter] let inside_word_delimiter = RegexSequence [RegexLimitPrev word_chars; RegexLimitNext word_chars] let left_line_delimiter = RegexLimitPrev (bof_chars "\r\n") let right_line_delimiter = RegexChoice [RegexSymbol (eof_chars "\r\n"); RegexSequence [RegexSymbol (singleton_char '\r'); RegexSymbol (singleton_char '\n')]] let bof_delimiter = RegexLimitPrev bof_char let eof_delimiter = RegexSymbol eof_char (* * Reduce a choice list. *) let regex_reduce_choices stack = match stack with [] -> RegexSequence [] | [regex] -> regex | _ -> RegexChoice (List.rev stack) (* * Reduce the stack, its just a sequence. *) let regex_reduce_sequence stack = match stack with [regex] -> regex | _ -> RegexSequence (List.rev stack) (* * Just saw a + *) let regex_reduce_plus stack = match stack with elem :: stack -> RegexPlus elem :: stack | [] -> [RegexSymbol (singleton_char '+')] let regex_reduce_star stack = match stack with elem :: stack -> RegexStar elem :: stack | [] -> [RegexSymbol (singleton_char '*')] let regex_reduce_opt stack = match stack with elem :: stack -> RegexChoice [elem; RegexSequence []] :: stack | [] -> [RegexSymbol (singleton_char '?')] let regex_reduce_interval stack n m = match stack with elem :: stack -> RegexInterval (elem, n, m) :: stack | [] -> [] (* * Interval expressions. *) let rec regex_interval n s i len = if i = len then raise (Failure "Lm_lexer: regex: interval expression is not terminated"); let j = succ i in let c = s.[i] in match c with '0'..'9' -> regex_interval (n * 10 + (Char.code c - Char.code '0')) s j len | ',' -> regex_interval_bound n 0 s j len | '}' -> n, n, j | _ -> raise (Failure "Lm_lexer: regex: interval expression is not terminated") and regex_interval_bound n m s i len = if i = len then raise (Failure "Lm_lexer: regex: interval expression is not terminated"); let j = succ i in let c = s.[i] in match c with '0'..'9' -> regex_interval_bound n (m * 10 + (Char.code c - Char.code '0')) s j len | '}' -> n, m, j | _ -> raise (Failure "Lm_lexer: regex: interval expression is not terminated") (* * Character constants. *) let rec regex_hex_const c s i len = if i = len then c, i else let c' = s.[i] in let j = succ i in match c' with '0'..'9' -> regex_hex_const (c * 16 + Char.code c' - zero_char) s j len | 'a'..'f' -> regex_hex_const (c * 16 + Char.code c' - hex_a_char) s j len | 'A'..'F' -> regex_hex_const (c * 16 + Char.code c' - hex_A_char) s j len | _ -> c, i let rec regex_octal_const c s i len = if i = len then c, i else let c' = s.[i] in match c' with '0'..'7' -> regex_octal_const (c * 8 + Char.code c' - zero_char) s (succ i) len | _ -> c, i (* * Literal characters [...] *) let rec regex_chars s i len = if i = len then raise (Failure "Lm_lexer: regex: character sequence is not terminated"); let j = succ i in match s.[i] with '^' -> let chars, j = regex_chars_head s j len in RegexExceptSymbol chars, j | _ -> let chars, j = regex_chars_head s i len in RegexSymbol chars, j (* * At the head, allow a literal ] *) and regex_chars_head s i len = if i = len then raise (Failure "Lm_lexer: regex: character sequence is not terminated"); match s.[i] with ']' -> regex_chars_rest (singleton_char ']') s (succ i) len | _ -> regex_chars_rest IntSet.empty s i len (* * Normal scanning. * Have to look for [:...:] sequences and ] *) and regex_chars_rest chars s i len = if i = len then raise (Failure "Lm_lexer: regex: character sequence is not terminated"); let j = succ i in match s.[i] with '[' -> regex_chars_possible_class chars s j len | ']' -> chars, j | '\\' -> regex_chars_escape chars s j len | c -> regex_chars_possible_range chars (Char.code c) s j len (* * Just saw a backslash. *) and regex_chars_escape chars s i len = if i = len then raise (Failure "Lm_lexer: regex: character sequence is not terminated"); let j = succ i in let c, j = match s.[i] with 'a' -> alert_char, j | 'b' -> backspace_char, j | 'f' -> formfeed_char, j | 'n' -> newline_char, j | 'r' -> cr_char, j | 't' -> tab_char, j | 'v' -> vertical_tab_char, j | 'x' -> regex_hex_const 0 s j len | '0'..'9' -> regex_octal_const 0 s i (min (i + 3) len) | c -> Char.code c, j in regex_chars_rest (IntSet.add chars c) s j len (* * Just seen a character, look for a character range c-c *) and regex_chars_possible_range chars c1 s i len = if i = len then raise (Failure "Lm_lexer: regex: character sequence not terminated"); let j = succ i in match s.[i] with '-' -> regex_chars_range chars c1 s j len | '[' -> regex_chars_possible_class (IntSet.add chars c1) s j len | ']' -> IntSet.add chars c1, j | '\\' -> regex_chars_escape (IntSet.add chars c1) s j len | c -> regex_chars_possible_range (IntSet.add chars c1) (Char.code c) s j len (* * Just seen a c-, get the remain char. *) and regex_chars_range chars c1 s i len = if i = len then raise (Failure "Lm_lexer: regex: character sequence not terminated"); let j = succ i in let c2 = Char.code s.[i] in let rec collect chars i = if i > c2 then chars else collect (IntSet.add chars i) (succ i) in let chars = collect chars c1 in regex_chars_rest chars s j len (* * Just saw a [, look for the : *) and regex_chars_possible_class chars s i len = if i = len then raise (Failure "Lm_lexer: regex: character sequence is not terminated"); let j = succ i in match s.[i] with ':' -> regex_chars_class chars s j len | '[' -> regex_chars_possible_class (IntSet.add chars (Char.code '[')) s j len | '\\' -> regex_chars_escape (IntSet.add chars (Char.code '[')) s j len | c -> regex_chars_rest (IntSet.add (IntSet.add chars (Char.code c)) (Char.code '[')) s j len (* * Get the character class specified by a sequence [:name:] *) and regex_chars_class chars s i len = let start = i in let rec get_name i = if i + 1 >= len then raise (Failure "Lm_lexer: regex: character class is not terminated"); let c = s.[i] in let j = succ i in match c with 'a'..'z' | 'A'..'Z' -> get_name j | ':' -> if s.[j] = ']' then regex_chars_get_class chars (String.sub s start (i - start)) s (succ j) len else raise (Failure "Lm_lexer: regex: character class: syntax error") | _ -> raise (Failure "Lm_lexer: regex: character class: syntax error") in get_name i (* * These are the standard classes. *) and regex_chars_get_class chars name s i len = let charclass = match String.lowercase_ascii name with "alnum" -> alnum_chars | "alpha" -> alpha_chars | "blank" -> blank_chars | "cntrl" -> cntrl_chars | "digit" -> digit_chars | "graph" -> graph_chars | "lower" -> lower_chars | "print" -> print_chars | "punct" -> punct_chars | "space" -> space_chars | "upper" -> upper_chars | "xdigit" -> xdigit_chars | name -> raise (Failure ("Lm_lexer: regex: unknown character class: " ^ name)) in regex_chars_rest (IntSet.union charclass chars) s i len (* * Parse an expression block. *) let rec regex_choices choices s i len = let regex, term = regex_of_string [] s i len in let choices = regex :: choices in match term with RegexTermEof -> regex_reduce_choices choices, term | RegexTermRightParen _ | RegexTermRightArg _ -> regex_reduce_choices choices, term | RegexTermPipe i -> regex_choices choices s i len and regex_left_paren s i len = let regex, term = regex_choices [] s i len in match term with RegexTermRightParen i -> regex, i | RegexTermRightArg _ | RegexTermEof -> raise (Failure "Lm_lexer: regex: mismatched parenthesis") | RegexTermPipe _ -> raise (Invalid_argument "regex_left_paren") and regex_left_arg s i len = let regex, term = regex_choices [] s i len in match term with RegexTermRightArg i -> regex, i | RegexTermRightParen _ | RegexTermEof -> raise (Failure "Lm_lexer: regex: mismatched parenthesis") | RegexTermPipe _ -> raise (Invalid_argument "regex_left_arg") (* * Parse the regular expression string. *) and regex_of_string stack s i len = if i = len then regex_reduce_sequence stack, RegexTermEof else let j = succ i in match s.[i] with '\\' -> regex_of_escape stack s j len | '.' -> let stack = RegexAnySymbol :: stack in regex_of_string stack s j len | '^' -> let stack = left_line_delimiter :: stack in regex_of_string stack s j len | '$' -> let stack = right_line_delimiter :: stack in regex_of_string stack s j len | '[' -> let regex, j = regex_chars s j len in let stack = regex :: stack in regex_of_string stack s j len | '+' -> let stack = regex_reduce_plus stack in regex_of_string stack s j len | '*' -> let stack = regex_reduce_star stack in regex_of_string stack s j len | '?' -> let stack = regex_reduce_opt stack in regex_of_string stack s j len | '(' -> let regex, j = regex_left_paren s j len in regex_of_string (regex :: stack) s j len | ')' -> regex_reduce_sequence stack, RegexTermRightParen j | '|' -> regex_reduce_sequence stack, RegexTermPipe j | '{' -> let min, max, j = regex_interval 0 s j len in let stack = regex_reduce_interval stack min max in regex_of_string stack s j len | c -> let stack = RegexSymbol (singleton_char c) :: stack in regex_of_string stack s j len (* * Escaped char. *) and regex_of_escape stack s i len = if i = len then raise (Failure "Lm_lexer: illegal backslash at end of string"); let j = succ i in match s.[i] with '(' -> let regex, j = regex_left_arg s j len in let stack = RegexArg regex :: stack in regex_of_string stack s j len | ')' -> regex_reduce_sequence stack, RegexTermRightArg j | '<' -> let stack = left_word_delimiter :: stack in regex_of_string stack s j len | '>' -> let stack = right_word_delimiter :: stack in regex_of_string stack s j len | 'y' -> let stack = word_delimiter :: stack in regex_of_string stack s j len | 'B' -> let stack = inside_word_delimiter :: stack in regex_of_string stack s j len | 'w' -> let stack = RegexSymbol word_chars :: stack in regex_of_string stack s j len | 'W' -> let stack = RegexExceptSymbol word_chars :: stack in regex_of_string stack s j len | '`' -> let stack = bof_delimiter :: stack in regex_of_string stack s j len | '\'' -> let stack = eof_delimiter :: stack in regex_of_string stack s j len | 'a' -> let stack = RegexSymbol alert_chars :: stack in regex_of_string stack s j len | 'b' -> let stack = RegexSymbol backspace_chars :: stack in regex_of_string stack s j len | 'f' -> let stack = RegexSymbol formfeed_chars :: stack in regex_of_string stack s j len | 'n' -> let stack = RegexSymbol newline_chars :: stack in regex_of_string stack s j len | 'r' -> let stack = RegexSymbol cr_chars :: stack in regex_of_string stack s j len | 't' -> let stack = RegexSymbol tab_chars :: stack in regex_of_string stack s j len | 'v' -> let stack = RegexSymbol vertical_tab_chars :: stack in regex_of_string stack s j len | 'x' -> let c, j = regex_hex_const 0 s j len in let stack = RegexSymbol (IntSet.singleton c) :: stack in regex_of_string stack s j len | '0'..'9' -> let c, j = regex_octal_const 0 s i (min (i + 3) len) in let stack = RegexSymbol (IntSet.singleton c) :: stack in regex_of_string stack s j len | c -> let stack = RegexSymbol (IntSet.singleton (Char.code c)) :: stack in regex_of_string stack s j len (* * The toplevel function. *) let regex_of_string s = let regex, term = regex_choices [] s 0 (String.length s) in let regex = match term with RegexTermEof -> regex | RegexTermRightParen _ | RegexTermRightArg _ -> raise (Failure "Lm_lexer: regex: mismatched parenthesis") | RegexTermPipe _ -> raise (Invalid_argument "regex_of_string") in if !debug_lexgen then Format.eprintf "@[Regex:@ @[string: \"%s\"@]@ @[regex:@ %a@]@]@." (**) s pp_print_regex regex; regex (************************************************************************ * Expressions. *) let pp_print_exp buf exp = let { exp_clauses = clauses; exp_id = id } = exp in Format.fprintf buf "Id: %d" id; List.iter (fun (action, id, regex) -> Format.fprintf buf "@ @[Clause:@ id = %d@ action = %a@ @[regex =@ %a@]@]" (**) id pp_print_action action pp_print_regex regex) clauses (* * An expression is a set of clauses. *) let empty_exp = { exp_clauses = []; exp_id = 0 } (* * Compute the number of arguments in the regex. *) let rec regex_arg_count count e = match e with RegexAnySymbol | RegexSymbol _ | RegexExceptSymbol _ | RegexLimitPrev _ | RegexLimitNext _ | RegexChoice [] -> count | RegexChoice (e :: _) | RegexStar e | RegexPlus e | RegexInterval (e, _, _) -> regex_arg_count count e | RegexSequence el -> List.fold_left regex_arg_count count el | RegexArg e -> regex_arg_count (succ count) e (* * Add a clause to the pre-NFA. *) let add_clause_exp exp action s = let regex = regex_of_string s in let arity = regex_arg_count 0 regex in let { exp_clauses = clauses; exp_id = id } = exp in let exp = { exp_clauses = (action, id, regex) :: clauses; exp_id = succ id } in arity, exp (* * Remove a clause. *) let remove_clause_exp exp action = let clauses = List.filter (fun (action', _, _) -> action' <> action) exp.exp_clauses in { exp with exp_clauses = clauses } (* * Take the union of two expression lists. *) let union_exp exp1 exp2 = let { exp_clauses = clauses1; exp_id = id1 } = exp1 in let { exp_clauses = clauses2; _ } = exp2 in let actions = List.fold_left (fun actions (action, _, _) -> ActionSet.add actions action) ActionSet.empty clauses1 in let rec collect id clauses1 clauses2 = match clauses2 with (action, _, regex) :: clauses2 -> if ActionSet.mem actions action then collect id clauses1 clauses2 else collect (succ id) ((action, id, regex) :: clauses1) clauses2 | [] -> id, clauses1 in let id, clauses1 = collect id1 clauses1 clauses2 in if id = id1 then false, exp1 else true, { exp_clauses = clauses1; exp_id = id } (************************************************************************ * NFA. *) let pp_print_nfa_id hash buf nid = match NfaState.get hash nid with | (nid, []) -> Lm_printf.pp_print_int buf nid | (nid, counters) -> Format.fprintf buf "<%d" nid; List.iter (fun counter -> Format.fprintf buf " %d" counter) counters; Format.fprintf buf ">" let pp_print_nfa_id_set hash buf states = NfaStateSet.iter (fun s -> Format.fprintf buf "@ %a" (pp_print_nfa_id hash) s) states (* let pp_print_choices buf choices = *) (* IntSet.iter (fun i -> Format.fprintf buf " %d" i) choices *) let pp_print_nfa_action buf action = match action with NfaActionEpsilon next -> Format.fprintf buf "@[(epsilon goto"; List.iter (fun i -> Format.fprintf buf "@ %d" i) next; Format.fprintf buf ")@]" | NfaActionArgStart (id, next) -> Format.fprintf buf "(arg-start %d goto %d)" id next | NfaActionArgStop (id, next) -> Format.fprintf buf "(arg-stop %d goto %d)" id next | NfaActionArgSearch next -> Format.fprintf buf "(arg-search goto %d)" next | NfaActionStop clause -> Format.fprintf buf "(stop [%d])" clause | NfaActionSymbol (syms, next) -> Format.fprintf buf "@[(symbols [%a]@ goto %d)@]" pp_print_chars syms next | NfaActionExceptSymbol (syms, next) -> Format.fprintf buf "@[(^symbols [%a]@ goto %d)@]" pp_print_chars syms next | NfaActionAnySymbol next -> Format.fprintf buf "(. goto %d)" next | NfaActionLimitPrev (syms, next) -> Format.fprintf buf "@[(limit-prev [%a]@ goto %d)@]" pp_print_chars syms next | NfaActionLimitNext (syms, next) -> Format.fprintf buf "@[(limit-next [%a]@ goto %d)@]" pp_print_chars syms next | NfaActionNone -> Format.fprintf buf "(final)" | NfaActionResetCounter (counter, next) -> Format.fprintf buf "@[(reset@ counter = %d@ goto" counter; List.iter (fun i -> Format.fprintf buf "@ %d" i) next; Format.fprintf buf ")@]" | NfaActionIncrCounter (counter, min, final, max, start) -> Format.fprintf buf "@[(increment@ counter = %d@ if count >= %d then goto %d@ if count <= %d then goto %d)@]" (**) counter min final max start let pp_print_nfa_state buf nfa_state = let { nfa_state_index = index; nfa_state_action = action } = nfa_state in Format.fprintf buf "@[NFA state %d:@ action %a@]" index pp_print_nfa_action action let pp_print_nfa buf nfa = let { nfa_hash = hash; nfa_start = start; nfa_search_start = search; nfa_search_states = search_states; nfa_table = table; _ } = nfa in Format.fprintf buf "@[NFA:@ start = %a@ search = %a@ @[search-states =%a@]" (**) (pp_print_nfa_id hash) start (pp_print_nfa_id hash) search (pp_print_nfa_id_set hash) search_states; Array.iter (fun state -> Format.fprintf buf "@ %a" pp_print_nfa_state state) table; Format.fprintf buf "@]" (************************************************ * Construct a new state. *) let nfa_state accum action = let { nfa_index = index ; _} = accum in let state = { nfa_state_index = index; nfa_state_action = action } in { accum with nfa_index = succ index }, state (* * Set the action. *) let set_action state action = { state with nfa_state_action = action } (* * Compile the NFA from a regex. * We are given a start and a final state, * and the task to to connect them according to the regex. * * Invariant: the provided start state is current NfaActionNone. * There is no such guarantee for the provided final state, and * it should not be modified. * * The states list contains all the states that are not the * start and final states. *) let rec compile (accum : nfa_accum) (info : nfa_info) start final states regex = match regex with (* Sequence *) RegexSequence regexl -> compile_sequence accum info start final states regexl (* Choice *) | RegexChoice [] -> let start = set_action start (NfaActionEpsilon [final.nfa_state_index]) in accum, info, start, states | RegexChoice [regex] -> compile accum info start final states regex | RegexChoice (regex :: regexl) -> let accum, info, starts, finals, states = compile_choice accum info states regex regexl in let start = set_action start (NfaActionEpsilon (List.map (fun state -> state.nfa_state_index) starts)) in let action = NfaActionEpsilon [final.nfa_state_index] in let finals = List.map (fun state -> set_action state action) finals in accum, info, start, starts @ finals @ states (* Symbols *) | RegexSymbol syms -> let start = set_action start (NfaActionSymbol (syms, final.nfa_state_index)) in accum, info, start, states | RegexExceptSymbol syms -> let start = set_action start (NfaActionExceptSymbol (syms, final.nfa_state_index)) in accum, info, start, states | RegexAnySymbol -> let start = set_action start (NfaActionAnySymbol final.nfa_state_index) in accum, info, start, states | RegexLimitPrev syms -> let start = set_action start (NfaActionLimitPrev (syms, final.nfa_state_index)) in accum, info, start, states | RegexLimitNext syms -> let start = set_action start (NfaActionLimitNext (syms, final.nfa_state_index)) in accum, info, start, states (* Kleene closure *) | RegexStar regex -> let accum, start1 = nfa_state accum NfaActionNone in let accum, final1 = nfa_state accum (NfaActionEpsilon [start1.nfa_state_index; final.nfa_state_index]) in let start = set_action start (NfaActionEpsilon [start1.nfa_state_index; final.nfa_state_index]) in let accum, info, start1, states = compile accum info start1 final1 states regex in accum, info, start, start1 :: final1 :: states | RegexPlus regex -> let accum, start1 = nfa_state accum NfaActionNone in let accum, final1 = nfa_state accum (NfaActionEpsilon [start1.nfa_state_index; final.nfa_state_index]) in let start = set_action start (NfaActionEpsilon [start1.nfa_state_index]) in let accum, info, start1, states = compile accum info start1 final1 states regex in accum, info, start, start1 :: final1 :: states | RegexInterval (regex, min, max) -> let { nfa_counter = counter; _ } = accum in let accum, start1 = nfa_state accum NfaActionNone in let accum, final1 = nfa_state accum (NfaActionIncrCounter (counter, min, final.nfa_state_index, max, start1.nfa_state_index)) in let start = let states = [start1.nfa_state_index] in let states = if min = 0 then final.nfa_state_index :: states else states in set_action start (NfaActionResetCounter (counter, states)) in let accum = { accum with nfa_counter = succ counter } in let accum, info, start1, states = compile accum info start1 final1 states regex in accum, info, start, start1 :: final1 :: states (* Arguments *) | RegexArg regex -> let { nfa_arg_index = argindex; _ } = accum in let accum, final1 = nfa_state accum (NfaActionArgStop (argindex, final.nfa_state_index)) in let accum, start1 = nfa_state accum NfaActionNone in let start = set_action start (NfaActionArgStart (argindex, start1.nfa_state_index)) in let { nfa_arg_number = argnumber; _ } = info in let accum = { accum with nfa_arg_index = succ argindex } in let info = { info with nfa_arg_number = succ argnumber } in let accum, info, start1, states = compile accum info start1 final1 states regex in accum, info, start, start1 :: final1 :: states (* * Choice. * Map over all the choices; make sure the argument counts match. *) and compile_choice accum info_orig states regex regexl = let accum, start = nfa_state accum NfaActionNone in let accum, final = nfa_state accum NfaActionNone in let accum, info1, start, states = compile accum info_orig start final states regex in let accum, info, starts, finals, states = List.fold_left (fun (accum, info1, starts, finals, states) regex -> let accum, start = nfa_state accum NfaActionNone in let accum, final = nfa_state accum NfaActionNone in let accum, info2, start, states = compile accum info_orig start final states regex in let () = if info1.nfa_arg_number <> info2.nfa_arg_number then raise (Failure "Lm_lexer: Regular expression has mismatched argument counts") in accum, info1, start :: starts, final :: finals, states) (**) (accum, info1, [start], [final], states) regexl in accum, info, starts, finals, states (* * Sequence. * Chain together the expressions. *) and compile_sequence accum info start final states regexl = match regexl with [] -> let start = set_action start (NfaActionEpsilon [final.nfa_state_index]) in accum, info, start, states | [regex] -> compile accum info start final states regex | regex :: regexl -> let accum, middle = nfa_state accum NfaActionNone in let accum, info, start, states = compile accum info start middle states regex in let accum, info, middle, states = compile_sequence accum info middle final states regexl in accum, info, start, middle :: states (* * Compile a clause. *) let compile_clause accum info states regex = let accum, final = nfa_state accum (NfaActionStop info.nfa_clause) in let accum, start = nfa_state accum NfaActionNone in let accum, info, start, states = compile accum info start final states regex in accum, info, start, final :: states (* * Create an actual NFA from the regular expression. * When lexing, we always start with the previous character * in the input (so we can handle \< expressions). * Add a new start state with a full set of transitions. *) let create_nfa exp = (* Initial accumulator and info *) let accum = { nfa_index = 0; nfa_counter = 0; nfa_arg_index = 0 } in (* Compile the expressions *) let accum, depends, actions, starts, states = List.fold_left (fun (accum, depends, actions, starts, states) (action, id, regex) -> let arg_offset = accum.nfa_arg_index in let info = { nfa_clause = id; nfa_arg_number = 0 } in let accum, _info, start, states = compile_clause accum info states regex in let arg_length = accum.nfa_arg_index - arg_offset in let arg_info = (arg_offset, arg_length) in let actions = IntTable.add actions id (action, arg_info) in let starts = start.nfa_state_index :: starts in let states = start :: states in accum, depends, actions, starts, states ) (accum, IntTable.empty, IntTable.empty, [], []) exp.exp_clauses in (* Add the normal start state *) let accum, choice = nfa_state accum (NfaActionEpsilon starts) in let accum, start = nfa_state accum (NfaActionAnySymbol choice.nfa_state_index) in let states = start :: choice :: states in (* Add a start state for searching '.*\(r\)' *) let accum, search_final = nfa_state accum (NfaActionArgSearch choice.nfa_state_index) in let accum, search_loop2 = nfa_state accum NfaActionNone in let accum, search_loop1 = nfa_state accum (NfaActionEpsilon [search_loop2.nfa_state_index; search_final.nfa_state_index]) in let search_loop2 = set_action search_loop2 (NfaActionAnySymbol search_loop1.nfa_state_index) in let accum, search_start = nfa_state accum (NfaActionAnySymbol search_loop1.nfa_state_index) in let states = search_start :: search_loop1 :: search_loop2 :: search_final :: states in let search_states = [search_start; search_loop1; search_loop2; search_final] in (* Build the table *) let length = List.length states in let table = Array.make length start in let counters = let rec collect l i = if i = 0 then l else collect (0 :: l) (pred i) in collect [] accum.nfa_counter in (* Hash it *) let hash = NfaState.create_state () in let start = NfaState.create hash (start.nfa_state_index, counters) in let search_start = NfaState.create hash (search_start.nfa_state_index, counters) in let search_states = List.fold_left (fun states state -> NfaStateSet.add states (NfaState.create hash (state.nfa_state_index, counters))) NfaStateSet.empty search_states in (* Add all the states to the table *) List.iter (fun state -> table.(state.nfa_state_index) <- state) states; (* Check that the states had unique indexes *) Array.iteri (fun i state -> assert (state.nfa_state_index = i)) table; { nfa_hash = hash; nfa_actions = actions; nfa_start = start; nfa_search_start = search_start; nfa_search_states = search_states; nfa_table = table; nfa_args = depends } (************************************************************************ * DFA * * The DFA is computed lazily from the NFA. *) (************************************************ * Printing. *) let pp_print_dfa_set hash buf closure = Format.fprintf buf "@[(set"; List.iter (fun i -> Format.fprintf buf "@ %a" (pp_print_nfa_id hash) i) closure; Format.fprintf buf ")@]" let pp_print_dfa_arg_action buf action = let { dfa_action_off = off; dfa_action_inst = inst } = action in match inst with DfaActionArgStart i -> Format.fprintf buf "arg-start %d at %d" i off | DfaActionArgStop i -> Format.fprintf buf "arg-stop %d at %d" i off | DfaActionArgSearch -> Format.fprintf buf "search-stop at %d" off let pp_print_dfa_actions nfa_hash buf action = let { dfa_action_final = final; dfa_action_actions = actions } = action in let () = Format.fprintf buf "@[(action" in let () = match final with Some (clause_id, nfa_id) -> Format.fprintf buf "@ final [clause=%d, nfa-state=%a]" clause_id (pp_print_nfa_id nfa_hash) nfa_id | None -> () in NfaStateTable.iter (fun dst action -> let { dfa_action_src = src; dfa_action_args = args } = action in Format.fprintf buf "@ @[(%a -> %a" (pp_print_nfa_id nfa_hash) src (pp_print_nfa_id nfa_hash) dst; List.iter (fun action -> Format.fprintf buf "@ %a" pp_print_dfa_arg_action action) args; Format.fprintf buf ")@]") actions; Format.fprintf buf ")@]" let pp_print_pre_actions buf action = let { pre_action_final = final; pre_action_args = args } = action in let () = Format.fprintf buf "@[(pre-action@ " in let () = match final with Some stop -> Format.fprintf buf "final [%d]@ " stop | None -> () in Format.fprintf buf "@[argument actions:"; List.iter (fun action -> Format.fprintf buf "@ %a" pp_print_dfa_arg_action action) args; Format.fprintf buf "@])@]" (* let pp_print_dfa_transition buf trans = *) (* match trans with *) (* DfaTransition (i, _) -> *) (* Format.fprintf buf "goto %d" i *) (* | DfaNoTransition -> *) (* Format.fprintf buf "error" *) (* | DfaUnknownTransition -> *) (* Format.fprintf buf "unknown" *) (* let pp_print_trans_table buf table = *) (* Format.fprintf buf "@[(trans"; *) (* Array.iter (fun (key, trans) -> *) (* Format.fprintf buf "@ %d -> %a" key pp_print_dfa_transition trans) table; *) (* Format.fprintf buf ")@]" *) (* * Print an argument. *) let pp_print_arg buf arg = match arg with ArgLeft i -> Format.fprintf buf "left[%d]" i | ArgRight i -> Format.fprintf buf "right[%d]" i | ArgSearch -> Format.fprintf buf "searchreg" (* * Print the frontier. *) let pp_print_frontier nfa_hash buf table = Format.fprintf buf "@[frontier:"; NfaStateTable.iter (fun id actions -> Format.fprintf buf "@ @[%a:@ %a@]" (pp_print_nfa_id nfa_hash) id pp_print_pre_actions actions) table; Format.fprintf buf "@]" (************************************************ * DFA. *) (* * Action operations. *) let pre_action_empty = { pre_action_final = None; pre_action_args = [] } let pre_action_add_stop action clause = match action.pre_action_final with Some clause' -> { action with pre_action_final = Some (Action.choose clause clause') } | None -> { action with pre_action_final = Some clause } let pre_action_add_arg actions arg = { actions with pre_action_args = arg :: actions.pre_action_args } let pre_action_add_arg_start actions off id = pre_action_add_arg actions { dfa_action_off = off; dfa_action_inst = DfaActionArgStart id } let pre_action_add_arg_stop actions off id = pre_action_add_arg actions { dfa_action_off = off; dfa_action_inst = DfaActionArgStop id } let pre_action_add_arg_search actions off = pre_action_add_arg actions { dfa_action_off = off; dfa_action_inst = DfaActionArgSearch } (* * DFA actions. *) let dfa_action_is_empty action = match action with { dfa_action_final = None; dfa_action_actions = actions } -> NfaStateTable.is_empty actions | { dfa_action_final = Some _ ; _ } -> false (* * Action evaluation. * We are given the argument info for each of the src states, * and we need to compute the argument info for each of the dst states. *) let dfa_apply_action pos args action = let { dfa_action_off = off; dfa_action_inst = inst } = action in let pos = pos + off in match inst with DfaActionArgStart i -> ArgTable.add args (ArgLeft i) pos | DfaActionArgStop i -> ArgTable.add args (ArgRight i) pos | DfaActionArgSearch -> ArgTable.add args ArgSearch pos let dfa_eval_action dfa info action = let { dfa_channel = channel; dfa_args = args_table; _ } = info in let { dfa_action_final = final; dfa_action_actions = actions } = action in let pos = Input.lex_pos channel in let args_table = NfaStateTable.map (fun action -> let { dfa_action_src = src; dfa_action_args = actions } = action in let args = try NfaStateTable.find args_table src with Not_found -> ArgTable.empty in List.fold_left (dfa_apply_action pos) args actions) actions in if !debug_lex then begin let pp_print_nfa_id = pp_print_nfa_id dfa.dfa_nfa_hash in Format.eprintf "@[Args:"; NfaStateTable.iter (fun id args -> Format.eprintf "@ @[state: %a" pp_print_nfa_id id; ArgTable.iter (fun arg i -> Format.eprintf "@ %a = %d" pp_print_arg arg i) args; Format.eprintf "@]") args_table; Format.eprintf "@]@." end; info.dfa_args <- args_table; (* Get final state *) match final with Some (clause_id, nid) -> info.dfa_stop_clause <- clause_id; info.dfa_stop_pos <- pos; info.dfa_stop_args <- NfaStateTable.find args_table nid | None -> () (* * We just scanned a symbol c in NFA state nid. * Compute the forward epsilon closure, and return the frontier * with the actions we should take for each NFA state in the frontier. *) let rec close_prev nfa_hash table nid c closure frontier actions = if DfaStateCore.mem closure nid then frontier else let index, counters = NfaState.get nfa_hash nid in let closure = DfaStateCore.add closure nid in let action = table.(index).nfa_state_action in if !debug_lexgen then Format.eprintf "@[close_prev:@ NFA state: %a@ Symbol: %a@ @[Closure:@ %a@]@ @[Frontier:@ %a@]@ @[NFA Action:@ %a@]@ @[Actions: %a@]@]@." (**) (pp_print_nfa_id nfa_hash) nid pp_print_char c (pp_print_dfa_set nfa_hash) closure (pp_print_frontier nfa_hash) frontier pp_print_nfa_action action pp_print_pre_actions actions; match action with (* Standard epsilon transitions *) NfaActionEpsilon nids -> let nids = List.map (fun index -> NfaState.create nfa_hash (index, counters)) nids in close_prev_list nfa_hash table nids c closure frontier actions (* Can only make progress if the current symbol is allowed *) | NfaActionLimitPrev (syms, nid) when IntSet.mem syms c -> let state = NfaState.create nfa_hash (nid, counters) in close_prev nfa_hash table state c closure frontier actions (* Arguments *) | NfaActionArgStart (id, nid) -> let actions = pre_action_add_arg_start actions 0 id in let state = NfaState.create nfa_hash (nid, counters) in close_prev nfa_hash table state c closure frontier actions | NfaActionArgStop (id, nid) -> let actions = pre_action_add_arg_stop actions 0 id in let state = NfaState.create nfa_hash (nid, counters) in close_prev nfa_hash table state c closure frontier actions | NfaActionArgSearch nid -> let actions = pre_action_add_arg_search actions 0 in let state = NfaState.create nfa_hash (nid, counters) in close_prev nfa_hash table state c closure frontier actions (* Counter operations *) | NfaActionResetCounter (i, nids) -> let counters = NfaStateCore.reset_counter counters i in let nids = List.map (fun index -> NfaState.create nfa_hash (index, counters)) nids in close_prev_list nfa_hash table nids c closure frontier actions | NfaActionIncrCounter (i, min, final, max, start) -> let nids = NfaStateCore.incr_counter counters i min final max start in let nids = List.map (NfaState.create nfa_hash) nids in close_prev_list nfa_hash table nids c closure frontier actions (* Reached a final state *) | NfaActionStop id -> let actions = pre_action_add_stop actions id in NfaStateTable.add frontier nid actions (* Reached the frontier, we can't make any more progress *) | NfaActionSymbol _ | NfaActionAnySymbol _ | NfaActionExceptSymbol _ | NfaActionLimitNext _ -> NfaStateTable.add frontier nid actions (* Dead-ends *) | NfaActionLimitPrev _ | NfaActionNone -> frontier and close_prev_list nfa_hash table nids c closure frontier actions = List.fold_left (fun frontier nid -> close_prev nfa_hash table nid c closure frontier actions) frontier nids (* * We are now processing symbol c in NFA state nid. * Search forward, computing the epsilon closure, until * we reach a transition on character c. * * pending: the actions that we take *only* if we eventually * find a transition on character c. * committed: the actions that we will take no matter what. *) let rec close_next nfa_hash table nid c closure frontier actions = if DfaStateCore.mem closure nid then frontier else let closure = DfaStateCore.add closure nid in let index, counters = NfaState.get nfa_hash nid in let action = table.(index).nfa_state_action in if !debug_lexgen then Format.eprintf "@[close_next:@ NFA state: %a@ Symbol: %a@ @[Closure:@ %a@]@ @[Frontier:@ %a@]@ @[NFA Action:@ %a@]@ @[Committed:@ %a@]@]@." (**) (pp_print_nfa_id nfa_hash) nid pp_print_char c (pp_print_dfa_set nfa_hash) closure (pp_print_frontier nfa_hash) frontier pp_print_nfa_action action pp_print_pre_actions actions; match action with (* These are the cases where we can make progress *) NfaActionSymbol (syms, nid) when IntSet.mem syms c -> let state = NfaState.create nfa_hash (nid, counters) in close_prev nfa_hash table state c DfaStateCore.empty frontier actions | NfaActionExceptSymbol (syms, nid) when not (c = eof || IntSet.mem syms c) -> let state = NfaState.create nfa_hash (nid, counters) in close_prev nfa_hash table state c DfaStateCore.empty frontier actions | NfaActionAnySymbol nid when c <> eof -> let state = NfaState.create nfa_hash (nid, counters) in close_prev nfa_hash table state c DfaStateCore.empty frontier actions | NfaActionLimitNext (syms, nid) when IntSet.mem syms c -> let state = NfaState.create nfa_hash (nid, counters) in close_next nfa_hash table state c closure frontier actions (* Standard epsilon transitions *) | NfaActionEpsilon nids -> let nids = List.map (fun index -> NfaState.create nfa_hash (index, counters)) nids in close_next_list nfa_hash table nids c closure frontier actions (* Arguments *) | NfaActionArgStart (id, nid) -> let actions = pre_action_add_arg_start actions (-1) id in let state = NfaState.create nfa_hash (nid, counters) in close_next nfa_hash table state c closure frontier actions | NfaActionArgStop (id, nid) -> let actions = pre_action_add_arg_stop actions (-1) id in let state = NfaState.create nfa_hash (nid, counters) in close_next nfa_hash table state c closure frontier actions | NfaActionArgSearch nid -> let actions = pre_action_add_arg_search actions (-1) in let state = NfaState.create nfa_hash (nid, counters) in close_next nfa_hash table state c closure frontier actions (* Counter operations *) | NfaActionResetCounter (i, nids) -> let counters = NfaStateCore.reset_counter counters i in let nids = List.map (fun index -> NfaState.create nfa_hash (index, counters)) nids in close_next_list nfa_hash table nids c closure frontier actions | NfaActionIncrCounter (i, min, final, max, start) -> let nids = NfaStateCore.incr_counter counters i min final max start in let nids = List.map (NfaState.create nfa_hash) nids in close_next_list nfa_hash table nids c closure frontier actions (* Dead-ends *) | NfaActionNone | NfaActionSymbol _ | NfaActionAnySymbol _ | NfaActionExceptSymbol _ | NfaActionLimitNext _ | NfaActionStop _ -> frontier (* These cases should never arise *) | NfaActionLimitPrev _ -> Format.eprintf "Illegal action: %a@." pp_print_nfa_action action; raise (Invalid_argument "close_next") and close_next_list nfa_hash table nids c closure frontier actions = List.fold_left (fun frontier nid -> close_next nfa_hash table nid c closure frontier actions) frontier nids (* * Compute the action table for each of the components of * the DFA state. *) let close_state dfa table nids c = let { dfa_search_states = search_states; dfa_nfa_hash = nfa_hash; _ } = dfa in let final, actions = List.fold_left (fun final_actions nid -> let frontier = close_next nfa_hash table nid c DfaStateCore.empty NfaStateTable.empty pre_action_empty in if !debug_lexgen then Format.eprintf "@[Frontier:@ %a@]@." (pp_print_frontier nfa_hash) frontier; NfaStateTable.fold (fun (final', actions) id action -> let { pre_action_final = final; pre_action_args = args } = action in let final = match final', final with Some (clause_id', _nid'), Some clause_id -> let clause_id'' = Action.choose clause_id' clause_id in if clause_id'' = clause_id' then final' else Some (clause_id, id) | Some _, None -> final' | None, Some clause_id -> Some (clause_id, id) | None, None -> None in let action = { dfa_action_src = nid; dfa_action_args = args } in let actions = (* * NOTE: currently we prefer states with smaller numbers, * which will result in a shortest match in the search prefix. * This works in many cases, but it may be wrong in general. *) NfaStateTable.filter_add actions id (fun action1 -> match action1 with Some action1 -> let id1, _ = NfaState.get nfa_hash action1.dfa_action_src in let id2, _ = NfaState.get nfa_hash nid in if id1 < id2 then action1 else action | None -> action) in final, actions) final_actions frontier) (None, NfaStateTable.empty) nids in let () = if !debug_lexgen then let actions = { dfa_action_final = final; dfa_action_actions = actions } in Format.eprintf "@[Computed actions:%a@]@." (pp_print_dfa_actions nfa_hash) actions in (* * If the state is final, and we have already scanned some text (not * including the initial bof), * 1. prune all states that correspond to the search * 2. prune all states that _came_ from the search, unless they * are the final state we care about. *) let actions = match final with Some (_, id) when c <> bof -> (* Remove target states in the search *) let actions = NfaStateSet.fold NfaStateTable.remove actions search_states in (* Remove target states that came from the search *) NfaStateTable.fold (fun actions id' action -> if NfaStateSet.mem search_states action.dfa_action_src && id' <> id then NfaStateTable.remove actions id' else actions) actions actions | _ -> actions in { dfa_action_final = final; dfa_action_actions = actions } (* * The next state is the frontier. *) let close_next_state dfa table nids c = let actions = close_state dfa table nids c in let frontier = NfaStateTable.fold (fun frontier nid _ -> nid :: frontier) [] actions.dfa_action_actions in let nfa_hash = dfa.dfa_nfa_hash in if !debug_lex then Format.eprintf "@[NFA transition:@ @[current:@ %a@]@ symbol: %a@ @[next:@ %a@]@ @[actions:@ %a@]@." (**) (pp_print_dfa_set nfa_hash) nids pp_print_char c (pp_print_dfa_set nfa_hash) frontier (pp_print_dfa_actions nfa_hash) actions; frontier, actions (* * Get the argument values. *) type arg_info = ArgStart of int | ArgStop of int | ArgComplete of int * int let rec extend_args args len1 len2 = if len1 = len2 then args else extend_args ("" :: args) (succ len1) len2 let dfa_args dfa_info group_select lexeme = let { dfa_start_pos = start; dfa_stop_pos = stop; dfa_stop_args = args; _ } = dfa_info in let (group_offset, group_length) = group_select in (* Get the pairs of argument info *) let info, start_pos = ArgTable.fold (fun (info, start) arg pos -> match arg with | ArgLeft arg -> let info = IntTable.filter_add info arg (fun entry -> match entry with | None -> ArgStart pos | Some (ArgStop right) -> ArgComplete (pos, right) | _ -> raise (Invalid_argument "dfa_args:left") ) in info, start | ArgRight arg -> let info = IntTable.filter_add info arg (fun entry -> match entry with | None -> ArgStop pos | Some (ArgStart left) -> ArgComplete (left, pos) | _ -> raise (Invalid_argument "dfa_args:right") ) in info, start | ArgSearch -> info, Some pos ) (IntTable.empty, None) args in (* Flatten the arguments *) let args, _ = IntTable.fold (fun (args, len) arg entry -> if arg >= group_offset && arg < group_offset + group_length then let s = (* Get the argument text *) match entry with | ArgComplete (left, right) -> String.sub lexeme left (right - left) | ArgStart left -> String.sub lexeme left (stop - left) | ArgStop right -> String.sub lexeme start (right - start) in let args = s :: extend_args args len (arg-group_offset) in args, succ (arg-group_offset) else args, len ) ([], 0) info in start_pos, List.rev args (* * Add a state to the DFA. It is initially empty. *) let dfa_find_state dfa nids = let { dfa_map = map; dfa_length = dfa_id; dfa_states = states; _ } = dfa in try DfaStateTable.find map nids with Not_found -> (* Make a new state *) let dfa_state = { dfa_state_index = dfa_id; dfa_state_set = nids; dfa_state_delta = TransTable.empty } in let () = (* Add to the map *) dfa.dfa_map <- DfaStateTable.add map nids dfa_id in let () = (* Add to the state array *) let length = Array.length states in if dfa_id = length then let new_states = Array.make (length * 2) dfa_state in Array.blit states 0 new_states 0 length; dfa.dfa_states <- new_states else states.(dfa_id) <- dfa_state in dfa.dfa_length <- succ dfa_id; dfa_id (* * We are in DFA state i, processing symbol c, but we don't have * an entry in the transition table yet. *) let create_entry dfa dfa_state c = let { dfa_dfa_hash = dfa_hash; dfa_table = table; _ } = dfa in let { dfa_state_set = nids; dfa_state_delta = delta; _ } = dfa_state in let frontier, actions = close_next_state dfa table (DfaState.get dfa_hash nids) c in if frontier = [] && dfa_action_is_empty actions then dfa_state.dfa_state_delta <- TransTable.add delta c DfaNoTransition else let frontier = DfaState.create dfa_hash frontier in let dfa_id = dfa_find_state dfa frontier in let entry = DfaTransition (dfa_id, actions) in dfa_state.dfa_state_delta <- TransTable.add delta c entry (* * Transition function. * We are in DFA state dfa_id, processing symbol c. * Returns None if there is no transition. *) let rec dfa_delta dfa dfa_info dfa_state c = match TransTable.find dfa_state.dfa_state_delta c DfaUnknownTransition with DfaTransition (dfa_id, actions) -> if !debug_lex then Format.eprintf "State %d %a: symbol %a, goto %d@." (**) dfa_state.dfa_state_index (pp_print_dfa_set dfa.dfa_nfa_hash) (DfaState.get dfa.dfa_dfa_hash dfa_state.dfa_state_set) pp_print_char c dfa_id; dfa_eval_action dfa dfa_info actions; Some (dfa.dfa_states.(dfa_id)) | DfaNoTransition -> if !debug_lex then Format.eprintf "State %d %a: no transition for symbol %a@." (**) dfa_state.dfa_state_index (pp_print_dfa_set dfa.dfa_nfa_hash) (DfaState.get dfa.dfa_dfa_hash dfa_state.dfa_state_set) pp_print_char c; None | DfaUnknownTransition -> if !debug_lex then Format.eprintf "State %d %a: computing transition on symbol %a@." (**) dfa_state.dfa_state_index (pp_print_dfa_set dfa.dfa_nfa_hash) (DfaState.get dfa.dfa_dfa_hash dfa_state.dfa_state_set) pp_print_char c; create_entry dfa dfa_state c; dfa_delta dfa dfa_info dfa_state c (* * Now the complete lexer. * We scan forward until no more transitions are possible. * Then return the last match. *) let lex dfa channel = let dfa_info = { dfa_stop_clause = -1; dfa_stop_pos = 0; dfa_stop_args = ArgTable.empty; dfa_start_pos = 0; dfa_args = NfaStateTable.empty; dfa_channel = channel } in let rec loop dfa_state c = match dfa_delta dfa dfa_info dfa_state c with Some dfa_state -> loop dfa_state (Input.lex_next channel) | None -> () in let dfa_state = dfa.dfa_states.(0) in let c = Input.lex_start channel in let () = loop dfa_state c in (* Now figure out what happened *) let { dfa_stop_clause = clause; dfa_stop_pos = stop; _ } = dfa_info in (* * If we did not get a match, return the channel to * the starting position, and raise an exception. *) if clause < 0 then begin Input.lex_stop channel 0; raise (Failure "Lm_lexer: lex: no clause matched") end; (* * We have the clause: * 1. Set the channel to the final position * 2. Get the entire string. * 3. Get the arguments. *) let action, group_info = IntTable.find dfa.dfa_action_table clause in let loc = Input.lex_loc channel stop in let lexeme = Input.lex_string channel stop in let _, args = dfa_args dfa_info group_info lexeme in Input.lex_stop channel stop; action, loc, lexeme, args (* * Return the input followed by a regular expression * terminator. *) let search dfa channel = let dfa_info = { dfa_stop_clause = -1; dfa_stop_pos = 0; dfa_stop_args = ArgTable.empty; dfa_start_pos = 0; dfa_args = NfaStateTable.empty; dfa_channel = channel } in let rec loop dfa_state c = match dfa_delta dfa dfa_info dfa_state c with Some dfa_state -> loop dfa_state (Input.lex_next channel) | None -> () in let dfa_state = dfa.dfa_states.(1) in let c = Input.lex_start channel in let () = loop dfa_state c in (* Now figure out what happened *) let { dfa_stop_clause = clause; dfa_stop_pos = stop; _ } = dfa_info in (* * If we did not get a match, return the channel to * the starting position, and raise an exception. *) if clause < 0 then begin Input.lex_stop channel 0; None end else (* * We have the clause: * 1. Set the channel to the final position * 2. Get the entire string. * 3. Get the arguments. *) let action, group_info = IntTable.find dfa.dfa_action_table clause in let loc = Input.lex_loc channel stop in let lexeme = Input.lex_string channel stop in let start, args = dfa_args dfa_info group_info lexeme in let skipped, lexeme = match start with Some pos -> String.sub lexeme 0 pos, String.sub lexeme pos (stop - pos) | None -> "", lexeme in Input.lex_stop channel stop; Some (action, loc, skipped, lexeme, args) (* * This is a slightly different version of searching, * where we skip to the EOF if there is no match. * * The reason for separating this is because it is a * hassle to deal with the 3 different return values * in the normal search function. *) let searchto dfa channel = let dfa_info = { dfa_stop_clause = -1; dfa_stop_pos = 0; dfa_stop_args = ArgTable.empty; dfa_start_pos = 0; dfa_args = NfaStateTable.empty; dfa_channel = channel } in let rec loop dfa_state c = match dfa_delta dfa dfa_info dfa_state c with Some dfa_state -> loop dfa_state (Input.lex_next channel) | None -> () in let dfa_state = dfa.dfa_states.(1) in let c = Input.lex_start channel in let () = loop dfa_state c in (* Now figure out what happened *) let { dfa_stop_clause = clause; dfa_stop_pos = stop; _ } = dfa_info in (* * If we did not get a match, return all the text to * the end of the channel. *) if clause < 0 then begin let stop = Input.lex_pos channel in if stop = 0 then begin Input.lex_stop channel stop; LexEOF end else let loc = Input.lex_loc channel stop in let lexeme = Input.lex_string channel stop in Input.lex_stop channel stop; LexSkipped (loc, lexeme) end else (* * We have the clause: * 1. Set the channel to the final position * 2. Get the entire string. * 3. Get the arguments. *) let action, group_info = IntTable.find dfa.dfa_action_table clause in let loc = Input.lex_loc channel stop in let lexeme = Input.lex_string channel stop in let start, args = dfa_args dfa_info group_info lexeme in let skipped, lexeme = match start with Some pos -> String.sub lexeme 0 pos, String.sub lexeme pos (stop - pos) | None -> "", lexeme in Input.lex_stop channel stop; LexMatched (action, loc, skipped, lexeme, args) (* * Just check for a string match. *) let matches dfa channel = match search dfa channel with None -> false | Some _ -> true (* * Create the DFA from a list of regular expressions. *) let create exp = let nfa = create_nfa exp in let () = if !debug_lexgen || !debug_lex then Format.eprintf "%a@." pp_print_nfa nfa in let { nfa_hash = nfa_hash; nfa_table = nfa_table; nfa_start = nfa_start; nfa_actions = actions; nfa_search_start = nfa_search_start; nfa_search_states = nfa_search_states; _ } = nfa in let dfa_hash = DfaState.create_state () in let nfa_start = DfaState.create dfa_hash [nfa_start] in let start = { dfa_state_index = 0; dfa_state_set = nfa_start; dfa_state_delta = TransTable.empty } in let nfa_search_start = DfaState.create dfa_hash [nfa_search_start] in let search_start = { dfa_state_index = 1; dfa_state_set = nfa_search_start; dfa_state_delta = TransTable.empty } in let map = DfaStateTable.empty in let map = DfaStateTable.add map nfa_start 0 in let map = DfaStateTable.add map nfa_search_start 1 in let states = Array.make 64 start in states.(1) <- search_start; { dfa_states = states; dfa_length = 2; dfa_map = map; dfa_table = nfa_table; dfa_action_table = actions; dfa_nfa_hash = nfa_hash; dfa_dfa_hash = dfa_hash; dfa_search_states = nfa_search_states } (* * External functions. *) let empty = { lex_exp = empty_exp; lex_dfa = None } let add_clause lex action s = let arity, exp = add_clause_exp lex.lex_exp action s in let lex = { lex_exp = exp; lex_dfa = None } in arity, lex let remove_clause lex action = { lex_exp = remove_clause_exp lex.lex_exp action; lex_dfa = None } (* * Take the union of two lexers. * We assume that if we have seen a clause before, * then we have seen all the rest of the clauses too. *) let union info1 info2 = let { lex_exp = exp1 ; _} = info1 in let { lex_exp = exp2 ; _} = info2 in (* Catch degenerate cases first *) match exp1.exp_clauses, exp2.exp_clauses with [], _ -> info2 | _, [] -> info1 | _ -> let changed, exp = union_exp exp1 exp2 in if changed then { lex_exp = exp; lex_dfa = None } else info1 let dfa_of_info info = match info.lex_dfa with Some dfa -> dfa | None -> let dfa = create info.lex_exp in info.lex_dfa <- Some dfa; dfa let lex info channel = lex (dfa_of_info info) channel let search info channel = search (dfa_of_info info) channel let searchto info channel = searchto (dfa_of_info info) channel let matches info channel = matches (dfa_of_info info) channel let compile info = ignore (dfa_of_info info) let pp_print_lexer buf info = let { lex_exp = exp ; _} = info in let dfa = dfa_of_info info in Format.fprintf buf "@[@[Lexer:@ %a@]" pp_print_exp exp; Format.fprintf buf "@ @[NFA:"; Array.iter (fun nfa_state -> Format.fprintf buf "@ %a" pp_print_nfa_state nfa_state) dfa.dfa_table; Format.fprintf buf "@]@]" let hash info = Hashtbl.hash_param max_int max_int info.lex_exp end (************************************************************************ * Simplified Str replacement. *) module LmAction = struct type action = int let pp_print_action = Lm_printf.pp_print_int let hash i = i let compare (i : int) (j : int) = if i < j then -1 else if i > j then 1 else 0 let choose = min end module LmLexer = MakeLexer (Lm_channel.LexerInput) (LmAction) module LmStr = struct type t = LmLexer.t (* * Create a regular expression. *) let regexp s = snd (LmLexer.add_clause LmLexer.empty 0 s) (* * Perform the match. *) let string_match info s off = let input = Lm_channel.of_substring s off (String.length s - off) in try let _ = LmLexer.lex info input in true with Failure _ -> false end omake-0.10.3/src/front/lm_parser.ml0000644000175000017500000025445013177364665015604 0ustar gerdgerdlet debug_parse = Lm_debug.create_debug (**) { debug_name = "parse"; debug_description = "Debug the parseer"; debug_value = false } let debug_parsegen = Lm_debug.create_debug (**) { debug_name = "parsegen"; debug_description = "Debug the parser generator"; debug_value = false } let debug_parsetiming = Lm_debug.create_debug (**) { debug_name = "parsetiming"; debug_description = "Display timing statistics for the parser generator"; debug_value = false } let debug_parse_conflict_is_warning = Lm_debug.create_debug (**) { debug_name = "parse_conflict_is_warning"; debug_description = "Do not abort on grammar conflicts"; debug_value = false } (* * A precedence directive is left-associative, right-associative, * or nonassociative. *) (* %%MAGICBEGIN%% *) type assoc = LeftAssoc | RightAssoc | NonAssoc | NoneAssoc (* %%MAGICEND%% *) let pp_print_assoc buf assoc = let s = match assoc with LeftAssoc -> "left" | RightAssoc -> "right" | NonAssoc -> "nona" | NoneAssoc -> "none" in Format.pp_print_string buf s (************************************************************************ * Tools for profiling. *) let time_start () = Unix.gettimeofday(), Unix.times () let time_print debug t1 t2 = if !debug_parsetiming then let now1, t1 = t1 in let now2, t2 = t2 in let now3 = Unix.gettimeofday () in let t3 = Unix.times () in let total = now3 -. now1 in let utime = t3.Unix.tms_utime -. t1.Unix.tms_utime in let stime = t3.Unix.tms_stime -. t1.Unix.tms_stime in let diff_total = now3 -. now2 in let diff_utime = t3.Unix.tms_utime -. t2.Unix.tms_utime in let diff_stime = t3.Unix.tms_stime -. t2.Unix.tms_stime in Format.eprintf "Time: %2.2f real %2.2f user %2.2f sys; %2.2f real %2.2f user %2.2f sys (%s)@." (**) diff_total diff_utime diff_stime total utime stime debug; now3, t3 else t1 (************************************************************************ * Precedences. *) module type PrecedenceArg = sig type t type precedence (* Precedence control *) val prec_min : precedence val prec_max : precedence (* Precedence tables *) val empty : t val create_prec_lt : t -> precedence -> assoc -> t * precedence val create_prec_gt : t -> precedence -> assoc -> t * precedence (* Print a precedence *) val pp_print_prec : t -> precedence Lm_printf.t (* Comparison *) val add_assoc : t -> precedence -> assoc -> t val assoc : t -> precedence -> assoc val compare : t -> precedence -> precedence -> int (* Tables and sets *) module PrecTable : Lm_map_sig.LmMap with type key = precedence end exception ParseError of Lm_location.t * string (* * The parser is parameterized over symbol and action names. *) module type ParserArg = sig (* Variable names: the names of terminals and nonterminals *) type symbol (* A symbol to represent eof *) val eof : symbol (* For debugging *) val to_string : symbol -> string val pp_print_symbol : symbol Lm_printf.t (* Sets and tables *) val hash_symbol : symbol -> int val compare_symbol : symbol -> symbol -> int (* Names of semantic actions *) type action (* For debugging *) val pp_print_action : action Lm_printf.t (* For set and table building *) val hash_action : action -> int val compare_action : action -> action -> int end module MakeParser (Arg : ParserArg) (Precedence : PrecedenceArg) = struct open Precedence (************************************************************************ * Types. *) (* * Type of lexing tokens. *) type ('a, 'b) lexer = 'a -> Arg.symbol * Lm_location.t * 'a * 'b type ('a, 'b) eval = 'a -> (* The argument *) Arg.action -> (* The name of the action *) Lm_location.t -> (* Location of the production *) 'b list -> (* The arguments to the action *) 'a * 'b (* The result of the semantic action *) (************************************************************************ * Internal versions of types. *) module VarArg = struct type t = Arg.symbol let debug = "Var" let hash = Arg.hash_symbol let compare = Arg.compare_symbol end;; module VarSet = Lm_set.LmMake (VarArg);; module VarTable = Lm_map.LmMake (VarArg);; module VarMTable = Lm_map.LmMakeList (VarArg);; module IVar = Lm_hash_cons.Make (VarArg);; module IVarSet = Lm_set.LmMake (IVar);; module IVarTable = Lm_map.LmMake (IVar);; module IVarMTable = Lm_map.LmMakeList (IVar);; type var = VarArg.t type ivar = IVar.t (* * Also hash the actions. *) module ActionArg = struct type t = Arg.action let debug = "Action" let hash = Arg.hash_action let compare = Arg.compare_action end;; module ActionSet = Lm_set.LmMake (ActionArg);; module IAction = Lm_hash_cons.Make (ActionArg);; module IActionSet = Lm_set.LmMake (IAction);; type action = ActionArg.t type iaction = IAction.t (* * A production item is represents a production with * a current position. *) (* %%MAGICBEGIN%% *) type prod_item_core = { prod_item_name : ivar; prod_item_left : ivar list; (* Reverse order *) prod_item_right : ivar list; prod_item_action : iaction; prod_item_prec : precedence } (* %%MAGICEND%% *) (* * Hash utilities. *) let ivar_list_hash hash vars = List.fold_left (fun hash v -> Lm_hash_code.hash_combine hash (IVar.hash v)) hash vars let rec ivar_list_compare vars1 vars2 = match vars1, vars2 with v1 :: vars1, v2 :: vars2 -> let cmp = IVar.compare v1 v2 in if cmp = 0 then ivar_list_compare vars1 vars2 else cmp | [], [] -> 0 | _ :: _, [] -> 1 | [], _ :: _ -> -1 module ProdItemArg = struct type t = prod_item_core let debug = "ProdItem" let hash item = let { prod_item_name = name; prod_item_left = left; prod_item_right = right; prod_item_action = action; _ } = item in let hash = Lm_hash_code.hash_combine (IVar.hash name) (IAction.hash action) in let hash = ivar_list_hash hash left in let hash = ivar_list_hash hash right in hash let compare item1 item2 = let { prod_item_name = name1; prod_item_left = left1; prod_item_right = right1; prod_item_action = action1; prod_item_prec = prec1 } = item1 in let { prod_item_name = name2; prod_item_left = left2; prod_item_right = right2; prod_item_action = action2; prod_item_prec = prec2 } = item2 in let cmp = IVar.compare name1 name2 in if cmp = 0 then let cmp = IAction.compare action1 action2 in if cmp = 0 then let cmp = ivar_list_compare left1 left2 in if cmp = 0 then let cmp = ivar_list_compare right1 right2 in if cmp = 0 then Pervasives.compare prec1 prec2 else cmp else cmp else cmp else cmp end module ProdItem = Lm_hash_cons.Make (ProdItemArg);; module ProdItemSet = Lm_set.LmMake (ProdItem);; module ProdItemTable = Lm_map.LmMake (ProdItem);; (* * An LR(0) state is a set of ProdItems, and * a closure, which is a set of nonterminals. *) (* %%MAGICBEGIN%% *) type info_state = { info_state_items : ProdItemSet.t; info_state_closure : IVarSet.t } (* %%MAGICEND%% *) module StateArg = struct type t = info_state let debug = "State" (* * We don't need to hash or compare the closure, * because it is uniquely determined by the items. *) let hash state = ProdItemSet.fold (fun hash item -> Lm_hash_code.hash_combine hash (ProdItem.hash item)) 0 state.info_state_items let compare state1 state2 = ProdItemSet.compare state1.info_state_items state2.info_state_items end;; module State = Lm_hash_cons.Make (StateArg);; module StateSet = Lm_set.LmMake (State);; module StateTable = Lm_map.LmMake (State);; (* * A StateItem is a pair of the state and the prod_item. *) module StateItemArg = struct type t = State.t * ProdItem.t let debug = "StateItem" let hash (state, item) = Lm_hash_code.hash_combine (State.hash state) (ProdItem.hash item) let compare (state1, item1) (state2, item2) = let cmp = ProdItem.compare item1 item2 in if cmp = 0 then State.compare state1 state2 else cmp end;; module StateItem = Lm_hash_cons.Make (StateItemArg);; module StateItemSet = Lm_set.LmMake (StateItem);; module StateItemTable = Lm_map.LmMake (StateItem);; (************************************************ * The grammar. *) (* * A production item is the production with position. * It does not include the lookahead. * * name ::= left . right * * We also keep the precedence of the production, * and its semantic action name. *) (* %%MAGICBEGIN%% *) (* * A single production. *) type prod = { prod_name : var; prod_right : var list; prod_action : action; prod_prec : precedence } (* * A grammar has a set of symbols, productions, * and precedences. *) type grammar = { gram_prod : prod VarMTable.t; gram_prec : precedence VarTable.t; gram_prec_table : Precedence.t; gram_start_symbols : VarSet.t } (************************************************ * The PDA. *) (* * An action is shift, reduce, or accept. *) type 'a pda_action = | ReduceAction of iaction * ivar * int (* semantic action, production name, #args *) | GotoAction of 'a | ErrorAction (* * We may reduce states without lookahead, * and we may accept. *) type pda_reduce = ReduceNone | ReduceNow of iaction * ivar * int | ReduceAccept of iaction * ivar * int (* * The PDA transition table. * * The pda_info is *purely* for debugging, so access * does not have to be fast. *) type pda_item = { pda_item_left : ivar list; (* Reverse order *) pda_item_right : ivar list } type pda_state_info = { pda_items : pda_item list; pda_next : IVarSet.t } type pda_state = { pda_delta : int pda_action IVarTable.t; pda_reduce : pda_reduce; pda_info : pda_state_info } type hash_state = { hash_ivar_state : IVar.state; hash_iaction_state : IAction.state; hash_prod_item_state : ProdItem.state; hash_state_state : State.state } type pda = { pda_start_states : int IVarTable.t; pda_states : pda_state array; pda_hash : hash_state } (* * The actual machine has a grammar and an optional pda. *) type t = { parse_grammar : grammar; mutable parse_pda : pda option } (* %%MAGICEND%% *) (* * Run time info. *) type ('a, 'b) run = { run_states : pda_state array; run_lexer : ('a, 'b) lexer; run_eval : ('a, 'b) eval } (************************************************ * Building the PDA. *) (* * Lookahead expressions. * LookAheadConst vars: the vars are spontaneously generated * LoadAheadProp vars: the vars are spontaneously generated, and the item vars are propagated. *) type lookahead = LookAheadConst of IVarSet.t | LookAheadProp of IVarSet.t (* * The info for constructing the PDA. * info_gram : the grammar * info_nullable : the nonterminals that derive epsilon * info_first : the terminals that may start a production *) type info = { info_grammar : grammar; info_prod : ProdItem.t list IVarTable.t; info_start_symbols : IVarSet.t; info_prec : precedence IVarTable.t; info_nullable : IVarSet.t; info_first : IVarSet.t IVarTable.t; info_head_delta : ProdItemSet.t IVarTable.t IVarTable.t; info_head_lookahead : lookahead IVarTable.t IVarTable.t; info_eof : IVar.t; info_hash : hash_state; info_hash_state_item : StateItem.state } (* * A prop_edge is used to specify that we should * propagate from one item to another. *) type prop_edge = { prop_edge_src : StateItem.t; (* state, item *) prop_edge_dst : StateItemSet.t (* state, item *) } (* * The prop_entry is the lookahead we are computing. *) type prop_entry = { prop_state_item : StateItem.t; mutable prop_changed : bool; mutable prop_vars : IVarSet.t } (* * A state element is a set of items, with lookaheads for each. *) (* type info_item = *) (* { info_item_index : int; *) (* info_item_empties : prop_entry list; *) (* info_item_closure : prop_entry list; *) (* info_item_entries : prop_entry array *) (* } *) (************************************************************************ * Printing and errors. *) (* let string_of_var v = *) (* Arg.to_string (Var.get v) *) let pp_print_var buf v = Arg.pp_print_symbol buf v (* (VarArg.get v) *) let pp_print_vars buf vl = List.iter (fun v -> Format.fprintf buf " %a" pp_print_var v) vl (* let pp_print_var_set buf s = *) (* VarSet.iter (fun v -> *) (* Format.fprintf buf "@ %a" pp_print_var v) s *) (* let pp_print_var_table buf table = *) (* VarTable.iter (fun v s -> *) (* Format.fprintf buf "@ @[%a:%a@]" (\**\) *) (* pp_print_var v *) (* pp_print_var_set s) table *) let pp_print_action buf action = Arg.pp_print_action buf ((* Action.get *) action) let string_of_ivar hash v = Arg.to_string (IVar.get hash.hash_ivar_state v) let pp_print_ivar hash buf v = Arg.pp_print_symbol buf (IVar.get hash.hash_ivar_state v) let pp_print_ivars hash buf vl = List.iter (fun v -> Format.fprintf buf " %a" (pp_print_ivar hash) v) vl let pp_print_ivar_set hash buf s = IVarSet.iter (fun v -> Format.fprintf buf "@ %a" (pp_print_ivar hash) v) s let pp_print_ivar_table hash buf table = IVarTable.iter (fun v s -> Format.fprintf buf "@ @[%a:%a@]" (**) (pp_print_ivar hash) v (pp_print_ivar_set hash) s) table let pp_print_iaction hash buf action = Arg.pp_print_action buf (IAction.get hash.hash_iaction_state action) let pp_print_prod gram buf item = let { prod_action = action; prod_prec = pre; prod_name = name; prod_right = right } = item in Format.fprintf buf "@[%a ::=%a [%a, %a]@]" (**) pp_print_var name pp_print_vars right pp_print_action action (Precedence.pp_print_prec gram.gram_prec_table) pre let pp_print_grammar buf gram = let { gram_prod = prods; gram_prec = precs; gram_prec_table = prec_table; gram_start_symbols = starts } = gram in Format.fprintf buf "@[Grammar:"; VarTable.iter (fun v pre -> Format.fprintf buf "@ prec %a = %a" (**) pp_print_var v (Precedence.pp_print_prec prec_table) pre) precs; VarSet.iter (fun v -> Format.fprintf buf "@ start %a" pp_print_var v) starts; VarMTable.iter_all (fun _ prods -> List.iter (fun prod -> Format.fprintf buf "@ %a" (pp_print_prod gram) prod) prods) prods; Format.fprintf buf "@]" let pp_print_pda_action hash buf action = match action with ReduceAction (action, _, _) -> Format.fprintf buf "reduce %a" (pp_print_iaction hash) action | GotoAction state -> Format.fprintf buf "goto %d" state | ErrorAction -> Format.pp_print_string buf "error" (* let pp_print_pda_actions info buf actions = *) (* IVarTable.iter (fun v action -> *) (* Format.fprintf buf "@ %a: %a" (pp_print_ivar info) v (pp_print_pda_action info) action) actions *) let pp_print_prod_item_core info buf item = let { prod_item_action = action; prod_item_name = name; prod_item_left = left; prod_item_right = right; _ } = item in let hash = info.info_hash in Format.fprintf buf "%a ::=%a .%a (%a)" (**) (pp_print_ivar hash) name (pp_print_ivars hash) (List.rev left) (pp_print_ivars hash) right (pp_print_iaction hash) action let pp_print_prod_item info buf item = pp_print_prod_item_core info buf (ProdItem.get info.info_hash.hash_prod_item_state item) let pp_print_prod_item_set info buf items = ProdItemSet.iter (fun item -> Format.fprintf buf "@ %a" (pp_print_prod_item info) item) items let pp_print_state info buf state = let { info_state_items = items; _ } = State.get info.info_hash.hash_state_state state in Format.eprintf "@[State %d" (State.hash state); pp_print_prod_item_set info buf items; Format.eprintf "@]" (* let pp_print_info_item info buf info_item = *) (* let { info_hash = hash; *) (* info_hash_state_item = hash_state_item; *) (* _ *) (* } = info *) (* in *) (* let { info_item_index = index; *) (* info_item_entries = entries; *) (* _ *) (* } = info_item *) (* in *) (* Format.fprintf buf "@[State %d:" index; *) (* Array.iter (fun entry -> *) (* let { prop_state_item = state_item; *) (* prop_vars = lookahead; *) (* _ *) (* } = entry *) (* in *) (* let _, prod_item = StateItem.get hash_state_item state_item in *) (* Format.fprintf buf "@ @[%a@ @[#%a@]@]" (pp_print_prod_item info) prod_item (pp_print_ivar_set hash) lookahead) entries; *) (* Format.fprintf buf "@]" *) let pp_print_info buf info = let { info_grammar = gram; info_nullable = nullable; info_first = first; info_hash = hash; _ } = info in Format.fprintf buf "@[%a" pp_print_grammar gram; Format.fprintf buf "@ @[Nullable:%a@]" (pp_print_ivar_set hash) nullable; Format.fprintf buf "@ @[First:%a@]" (pp_print_ivar_table hash) first; Format.fprintf buf "@]" let pp_print_lookahead hash buf look = match look with LookAheadConst set -> Format.fprintf buf "@[const%a@]" (pp_print_ivar_set hash) set | LookAheadProp set -> Format.fprintf buf "@[prop%a@]" (pp_print_ivar_set hash) set (* * Print a transition table. *) let pp_print_delta info buf delta = let pp_print_ivar = pp_print_ivar info.info_hash in let pp_print_prod_item_set = pp_print_prod_item_set info in IVarTable.iter (fun v delta -> Format.fprintf buf "@ @[%a ->" pp_print_ivar v; IVarTable.iter (fun v item -> Format.fprintf buf "@ @[%a ->%a@]" pp_print_ivar v pp_print_prod_item_set item) delta; Format.fprintf buf "@]") delta (* * Print the lookahead table. *) let pp_print_look_table info buf table = let hash = info.info_hash in let pp_print_ivar = pp_print_ivar hash in let pp_print_lookahead = pp_print_lookahead hash in IVarTable.iter (fun v table -> Format.fprintf buf "@ @[%a ->" pp_print_ivar v; IVarTable.iter (fun v look -> Format.fprintf buf "@ %a -> %a" pp_print_ivar v pp_print_lookahead look) table; Format.fprintf buf "@]") table (************************************************************************ * Grammar construction. *) (* * Empty grammar has the basic precedences. *) let empty_grammar = { gram_prod = VarMTable.empty; gram_prec = VarTable.empty; gram_prec_table = Precedence.empty; gram_start_symbols = VarSet.empty } (* * Add a start symbol. *) let add_start gram sym = { gram with gram_start_symbols = VarSet.add gram.gram_start_symbols sym(* (Var.create sym) *) } (* * Add a symbol at a given precedence level. *) let add_prec gram pre v = { gram with gram_prec = VarTable.add gram.gram_prec v pre } (* * Find the precedence level for a symbol. *) let find_prec gram v = VarTable.find gram.gram_prec v (* * Add a production. * If the precedence is not specified, it is the precedence * of the rightmost variable that has a precedence. *) let add_production gram action v rhs pre = let pre = match pre with Some sym -> find_prec gram sym | None -> List.fold_left (fun pre v -> try VarTable.find gram.gram_prec v with Not_found -> pre) prec_min rhs in let prod = { prod_action = action; prod_name = v; prod_right = rhs; prod_prec = pre } in { gram with gram_prod = VarMTable.add gram.gram_prod v prod } (* * Remove a production. * We don't index by production name, so this takes linear time * in the number of productions. *) let remove_production gram action = let table = VarMTable.mapi_all (fun _ prods -> List.filter (fun prod -> prod.prod_action <> action) prods) gram.gram_prod in { gram with gram_prod = table } (* * Precedence union is a little hard. * Suppose the second grammar contains some precedence * levels that do not occur in the first grammar. We * have to insert some levels, and we have to figure out * where to put them. * * The basic idea is to build an inverse table for the * second grammar. Then sort this grammar, and walk * through each level. If it exists in the first grammar, * keep it. Otherwise add a new level, and continue. *) let rec find_existing_prec precs vars = match vars with [] -> None | v :: vars -> try Some (VarTable.find precs v) with Not_found -> find_existing_prec precs vars let add_precs precs vars pre = List.fold_left (fun precs v -> VarTable.add precs v pre) precs vars let union_prec prec1 table1 prec2 table2 = (* Build an inverse precedence table for grammar2 *) let inv_table = VarTable.fold (fun inv_table v pre -> PrecTable.filter_add inv_table pre (fun vars -> let vars = match vars with Some vars -> vars | None -> [] in v :: vars)) PrecTable.empty prec2 in (* Sort the precedences in grammar2 *) let prec_list = PrecTable.fold (fun prec_list pre _ -> pre :: prec_list) [] inv_table in let prec_list = List.sort (Precedence.compare table2) prec_list in (* Initial translation *) let translate = PrecTable.empty in let translate = PrecTable.add translate prec_min prec_min in let translate = PrecTable.add translate prec_max prec_max in (* Walk through each level, and create it if it doesn't already exist *) let translate, precs, table, _ = List.fold_left (fun (translate, precs, table, prev_prec) pre -> let vars = PrecTable.find inv_table pre in let table, current_prec = match find_existing_prec precs vars with Some current_prec -> table, current_prec | None -> let assoc = Precedence.assoc table2 pre in Precedence.create_prec_gt table prev_prec assoc in let translate = PrecTable.add translate pre current_prec in let precs = add_precs precs vars current_prec in translate, precs, table, current_prec) (translate, prec1, table1, Precedence.prec_min) prec_list in translate, precs, table (* * Union of two grammars. *) let union_grammar gram1 gram2 = let { gram_prod = prod1; gram_prec = prec1; gram_prec_table = prec_table1; gram_start_symbols = start1 } = gram1 in let { gram_prod = prod2; gram_prec = prec2; gram_prec_table = prec_table2; gram_start_symbols = start2 } = gram2 in (* Compute the new precedence table *) let prec_translate, precs, prec_table = union_prec prec1 prec_table1 prec2 prec_table2 in (* Get the complete set of actions for the first parser *) let actions = VarMTable.fold_all (fun actions _ prods -> List.fold_left (fun actions prod -> let action = prod.prod_action in ActionSet.add actions action) actions prods) ActionSet.empty prod1 in (* Take the union of the productions *) let changed, prods = VarMTable.fold_all (fun (changed, prods) _ prodlist -> List.fold_left (fun (changed, prods) prod -> let { prod_action = action; prod_name = name; prod_prec = pre; _ } = prod in if ActionSet.mem actions action then changed, prods else let prod = { prod with prod_prec = PrecTable.find prec_translate pre } in true, VarMTable.add prods name prod) (changed, prods) prodlist) (false, prod1) prod2 in (* Union of the start symbols *) let start = VarSet.union start1 start2 in (* Has anything changed? *) let changed = changed || (VarTable.cardinal precs <> VarTable.cardinal prec1) || (VarSet.cardinal start <> VarSet.cardinal start1) in (* New grammar *) let gram = { gram_prod = prods; gram_prec = precs; gram_prec_table = prec_table; gram_start_symbols = start } in changed, gram (* * Debugging version. *) let union_grammar gram1 gram2 = if !debug_parsegen then Format.eprintf "@[Grammar union:@ @[Grammar1:@ %a@]@ @[Grammar2:@ %a@]@]@." (**) pp_print_grammar gram1 pp_print_grammar gram2; let changed, gram = union_grammar gram1 gram2 in if !debug_parsegen then Format.eprintf "@[Grammar union %b:@ %a@]@." (**) changed pp_print_grammar gram; changed, gram (************************************************************************ * Initial info for LALR(1) construction. *) (* * A nonterminal is nullable if all variables on the rhs are nullable. *) let nullable hash prods = let prod_state = hash.hash_prod_item_state in let step nullable prods = IVarTable.fold (fun nullable v prods -> if IVarSet.mem nullable v then nullable else if List.exists (fun prod -> List.for_all (IVarSet.mem nullable) (**) (ProdItem.get prod_state prod).prod_item_right) prods then IVarSet.add nullable v else nullable) nullable prods in let rec fixpoint nullable prods = let nullable' = step nullable prods in if IVarSet.cardinal nullable' <> IVarSet.cardinal nullable then fixpoint nullable' prods else nullable in fixpoint IVarSet.empty prods (* * Find the sets of first symbols that can start productions. *) let rec first_rhs nullable first set rhs = match rhs with v :: rhs -> let set = IVarSet.union set (IVarTable.find first v) in if IVarSet.mem nullable v then first_rhs nullable first set rhs else set | [] -> set let first hash prods nullable = let prod_state = hash.hash_prod_item_state in let step first prods = IVarTable.fold (fun (first, changed) _ prods -> List.fold_left (fun (first, changed) prod -> let { prod_item_name = x; prod_item_right = rhs; _ } = ProdItem.get prod_state prod in let set = IVarTable.find first x in let set' = first_rhs nullable first set rhs in let set, changed = if changed || IVarSet.cardinal set' <> IVarSet.cardinal set then set', true else set, false in let first = IVarTable.add first x set in first, changed) (first, changed) prods) (first, false) prods in let rec fixpoint first prods = let first, changed = step first prods in if changed then fixpoint first prods else first in (* Initialize with the terminals *) let vars = IVarTable.fold (fun vars v prods -> let vars = IVarSet.add vars v in List.fold_left (fun vars prod -> List.fold_left IVarSet.add vars (ProdItem.get prod_state prod).prod_item_right) vars prods) IVarSet.empty prods in let first = IVarSet.fold (fun first v -> if IVarTable.mem prods v then IVarTable.add first v IVarSet.empty else IVarTable.add first v (IVarSet.singleton v)) IVarTable.empty vars in fixpoint first prods (************************************************************************ * LR(0) construction. *) (* * Get the set of first symbols that can begin a list. *) let lookahead info rhs = let { info_first = first; info_nullable = nullable; _ } = info in let rec search set rhs = match rhs with v :: rhs -> let set = IVarSet.union (IVarTable.find first v) set in if IVarSet.mem nullable v then search set rhs else LookAheadConst set | [] -> LookAheadProp set in search IVarSet.empty rhs (* * Concatenate lookahead sets. *) let lookahead_concat look1 look2 = match look1, look2 with LookAheadConst _, _ -> look1 | LookAheadProp set1, LookAheadConst set2 -> LookAheadConst (IVarSet.union set1 set2) | LookAheadProp set1, LookAheadProp set2 -> LookAheadProp (IVarSet.union set1 set2) (* * Two different paths for lookahead. *) let lookahead_union look1 look2 = match look1, look2 with LookAheadConst set1, LookAheadConst set2 -> LookAheadConst (IVarSet.union set1 set2) | LookAheadProp set1, LookAheadConst set2 | LookAheadConst set1, LookAheadProp set2 | LookAheadProp set1, LookAheadProp set2 -> LookAheadProp (IVarSet.union set1 set2) (* * Comparison. *) let lookahead_equal look1 look2 = match look1, look2 with LookAheadConst set1, LookAheadConst set2 | LookAheadProp set1, LookAheadProp set2 -> IVarSet.equal set1 set2 | LookAheadConst _, LookAheadProp _ | LookAheadProp _, LookAheadConst _ -> false (* * Split into a pair. *) let lookahead_pair look = match look with LookAheadConst set -> false, set | LookAheadProp set -> true, set let lookahead_set look = match look with LookAheadConst set | LookAheadProp set -> set (************************************************ * Produce the derivation table for items where * the dot is at the head. * * We want a transition table, as well as lookaheads. * * The transition table gives a set of transitions * for nonterminal (symbol -> symbol -> ProdItemSet.t), * where and entry (v1 -> v2 -> items) states that: * if looking at v1, * you can goto on v2, * with the resulting items. * * The pre-lookahead gives a similar table. The entry * (v1 -> v2 -> look) means: * For nonterminal v1, there is an item * . v2 right_2 * where v2 is a nonterminal and * look = LOOKAHEAD(right_2) *) (* * Compute the transition function and lookahead table * for an item. *) let build_head_item info delta lookaheads item = let core = ProdItem.get info.info_hash.hash_prod_item_state item in match core.prod_item_right with v :: right -> let core = { core with prod_item_left = [v]; prod_item_right = right } in let item = ProdItem.create info.info_hash.hash_prod_item_state core in let delta = IVarTable.filter_add delta v (fun items -> match items with Some items -> ProdItemSet.add items item | None -> ProdItemSet.singleton item) in let look1 = lookahead info right in let lookaheads = if IVarTable.mem info.info_prod v then IVarTable.filter_add lookaheads v (fun look2 -> match look2 with Some look2 -> lookahead_union look1 look2 | None -> look1) else lookaheads in delta, lookaheads | [] -> delta, lookaheads let build_head_items info items = List.fold_left (fun (delta, lookaheads) item -> build_head_item info delta lookaheads item) (IVarTable.empty, IVarTable.empty) items (* * Solve the lookahead functions. * This is a fixpoint, but it should be pretty cheap. * * This flatten lookahead is defined as follows. * The table has an entry (v1 -> v2 -> look) iff: * 1. There is a derivation (v1 --> v2 right2) * 2. v2 is a nonterminal * 3. look = LOOKAHEAD(right2) * The main issue is that right2 may be constructed from * the right-hand-sides of several productions. *) let build_lookahead_item _info table v = (* Fixpoint *) let step venv = IVarTable.fold (fun (venv, changed) v e1 -> let next = IVarTable.find table v in IVarTable.fold (fun (venv, changed) v e2 -> let e = lookahead_concat e2 e1 in try let e_old = IVarTable.find venv v in let e_new = lookahead_union e_old e in if lookahead_equal e_old e_new then venv, changed else IVarTable.add venv v e_new, true with Not_found -> IVarTable.add venv v e, true) (venv, changed) next) (venv, false) venv in let rec fixpoint venv = let venv, changed = step venv in if changed then fixpoint venv else venv in fixpoint (IVarTable.add IVarTable.empty v (LookAheadProp IVarSet.empty)) let build_lookaheads info table = IVarTable.mapi (fun v _ -> build_lookahead_item info table v) table (* * Main function. *) let build_head_table info start now = let delta_table, look_table = IVarTable.fold (fun (delta_table, look_table) v items -> let delta, lookaheads = build_head_items info items in let delta_table = IVarTable.add delta_table v delta in let look_table = IVarTable.add look_table v lookaheads in delta_table, look_table) (IVarTable.empty, IVarTable.empty) info.info_prod in let () = if !debug_parsegen then Format.eprintf "@[Head table:@ @[Delta:%a@]@ @[Lookahead:%a@]@]@." (**) (pp_print_delta info) delta_table (pp_print_look_table info) look_table in let now = time_print "Head items" start now in let look_table = build_lookaheads info look_table in let () = if !debug_parsegen then Format.eprintf "@[Closed lookahead:%a@]@." (**) (pp_print_look_table info) look_table in let now = time_print "Lookaheads" start now in now, delta_table, look_table (************************************************ * Producing the state table. *) (* * Produce a transition table by shifting. * We take a set of items, and produce a IVarTable * containing the next states. *) let shift_items info items = let hash = info.info_hash.hash_prod_item_state in ProdItemSet.fold (fun delta prod_item -> let core = ProdItem.get hash prod_item in let { prod_item_left = left; prod_item_right = right; _ } = core in match right with v :: right -> let core = { core with prod_item_left = v :: left; prod_item_right = right } in let item = ProdItem.create hash core in IVarTable.filter_add delta v (fun items -> match items with Some items -> ProdItemSet.add items item | None -> ProdItemSet.singleton item) | [] -> delta) IVarTable.empty items (* * Shift a closure, given the current state. * This produces a IVarTable that defines the next * state for each symbol. *) let shift_state info state = let core = State.get info.info_hash.hash_state_state state in let { info_state_items = items; info_state_closure = next } = core in let head_table = info.info_head_delta in let delta = shift_items info items in IVarSet.fold (fun delta v -> let head_delta = IVarTable.find head_table v in IVarTable.fold (fun delta v items -> IVarTable.filter_add delta v (fun current_items -> match current_items with Some current_items -> ProdItemSet.union current_items items | None -> items)) delta head_delta) delta next (* * A closure is represented by its kernel (all the * items where the dot is not at the front), plus * the names of all the productions where the dot * is at the front. *) let closure info items = let look_table = info.info_head_lookahead in let closure = ProdItemSet.fold (fun closure item -> let core = ProdItem.get info.info_hash.hash_prod_item_state item in match core.prod_item_right with v :: _ when IVarTable.mem look_table v -> let look = IVarTable.find look_table v in IVarTable.fold (fun closure v _ -> IVarSet.add closure v) (IVarSet.add closure v) look | _ -> closure) IVarSet.empty items in let state = { info_state_items = items; info_state_closure = closure } in State.create info.info_hash.hash_state_state state (* * Compute the transition table, only for shift operations. *) let build_delta info unexamined = (* Perform the closure *) let rec build shift_table examined unexamined = if StateSet.is_empty unexamined then shift_table, examined else (* Move an item from unexamined to examined *) let state = StateSet.choose unexamined in let examined = StateSet.add examined state in let unexamined = StateSet.remove unexamined state in (* Compute the goto states *) let delta = shift_state info state in let goto_table, unexamined = IVarTable.fold (fun (goto_table, unexamined) v items -> let state = closure info items in let unexamined = if StateSet.mem examined state then unexamined else StateSet.add unexamined state in let goto_table = IVarTable.add goto_table v state in goto_table, unexamined) (IVarTable.empty, unexamined) delta in let shift_table = StateTable.add shift_table state goto_table in build shift_table examined unexamined in build StateTable.empty StateSet.empty unexamined let build_start_state info start_table unexamined start = let prods = try IVarTable.find info.info_prod start with Not_found -> raise (Failure ("no such production: " ^ string_of_ivar info.info_hash start)) in let set = List.fold_left ProdItemSet.add ProdItemSet.empty prods in let state = closure info set in let unexamined = StateSet.add unexamined state in let start_table = IVarTable.add start_table start state in start_table, unexamined let build_state_table info = let () = if !debug_parsegen then Format.eprintf "@[Grammar:@ %a@]@." pp_print_info info in let start_table, unexamined = IVarSet.fold (fun (start_table, unexamined) start -> build_start_state info start_table unexamined start) (**) (IVarTable.empty, StateSet.empty) info.info_start_symbols in let shift_table, states = build_delta info unexamined in start_table, shift_table, states (************************************************************************ * LALR(1) construction. * * Once we have the set of LR(0) states, we need to propagate lookahead * sets. For each item in a state, figure out what symbols are propagated * and which are spontaneously generated, then perform a fixpoint. *) (* * Build the empty propagation table. * It has an entry for each StateItem. *) let build_prop_empty info states = (* First, construct each StateItem *) let state_hash = info.info_hash.hash_state_state in let state_item_hash = info.info_hash_state_item in StateSet.iter (fun state -> let core = State.get state_hash state in let items = core.info_state_items in ProdItemSet.iter (fun item -> ignore (StateItem.create state_item_hash (state, item))) items) states; (* The prop table is an array from the hash code to the prop_entry *) StateItem.map_array (fun item _ -> { prop_state_item = item; prop_changed = true; prop_vars = IVarSet.empty }) state_item_hash (* * Add the propagation info for the initial items. * * We are looking at an item. * item = left . v1 right * * Suppose v1 is a nonterminal, and we have some derivation * with head nonterminal v2 (perhaps v1 = v2, and right_1 * is empty). * * v1 --> . v2 right_1 * * Suppose v2 has the following production. * * v2 = v3 right_2 * * Then the goto(X) state contains an item: * * v3 . right_2 * * We need to propagate lookaheads to this item. * Propagate FIRST(right_2 right_1) as spontaneous * lookaheads. If NULLABLE(right_2 right_1), then * propagate lookaheads from this item. * * By definition, the lookahead entry for v1 contains * and entry (v2 -> look) for each nonterminal v2 * for which (v1 --> v2 right2), and "look" is the * lookahead to be used in such a case. * * So the algorithm works as follows: * Let look1 be LOOKAHEAD(right1): * For each entry (v2, look2) in the lookahead table: * For each transition (v2 -X-> X . right): * Add lookaheads (look2 look1) to the item "X . right" *) let build_prop_head info prop_table goto_table v1 right1 = (* Look up the derivations for v *) let delta_table = info.info_head_delta in let look_table = IVarTable.find info.info_head_lookahead v1 in let look1 = lookahead info right1 in let hash_state_item = info.info_hash_state_item in IVarTable.fold (fun prop_items v2 look2 -> let look = lookahead_concat look2 look1 in let prop, vars = lookahead_pair look in let delta = IVarTable.find delta_table v2 in IVarTable.fold (fun prop_items v3 items -> ProdItemSet.fold (fun prop_items next_item -> (* Add the edge *) let next_state = IVarTable.find goto_table v3 in let next = StateItem.create hash_state_item (next_state, next_item) in (* Add the edge if we need to propagate *) let prop_items = if prop then StateItemSet.add prop_items next else prop_items in (* Initial propagation *) let prop_entry = prop_table.(StateItem.hash next) in prop_entry.prop_vars <- IVarSet.union prop_entry.prop_vars vars; prop_items) prop_items items) prop_items delta) StateItemSet.empty look_table (* * Add the propagation info for a state_item. * * Propagate initial items. * * In addition, if the item is: * * item = left . X right * * then goto(X) contains the item * * left v . right * * Propagate lookaheads directly to this item. *) let build_prop_state info prop_table shift_table prop_edges state_item = let state_item_hash = info.info_hash_state_item in let state, prod_item = StateItem.get state_item_hash state_item in let goto_table = StateTable.find shift_table state in let prod_item_hash = info.info_hash.hash_prod_item_state in let prod_item_core = ProdItem.get prod_item_hash prod_item in let { prod_item_left = left; prod_item_right = right; _ } = prod_item_core in match right with v :: right -> (* If v is a nonterminal, then also propagate to initial items *) let prop_items = if IVarTable.mem info.info_prod v then build_prop_head info prop_table goto_table v right else StateItemSet.empty in (* Propagate directly to the next state *) let next_state = IVarTable.find goto_table v in let next_item_core = { prod_item_core with prod_item_left = v :: left; prod_item_right = right } in let next_item = ProdItem.create prod_item_hash next_item_core in let next = StateItem.create state_item_hash (next_state, next_item) in (* Add the edges, but remove any self-edge (because it is useless) *) let prop_items = StateItemSet.add prop_items next in let prop_items = StateItemSet.remove prop_items state_item in let prop_edge = { prop_edge_src = state_item; prop_edge_dst = prop_items } in prop_edge :: prop_edges | [] -> prop_edges (* * Now construct a propagation network. * Each state is represented as an array of production indices, * each with a propagation entry to another item identified * by (state, index). *) let build_prop_table info shift_table states = let prop_table = build_prop_empty info states in let prop_edges = StateItem.fold (build_prop_state info prop_table shift_table) [] info.info_hash_state_item in prop_table, prop_edges (* * Add the eof symbol for the start states. *) let set_start_lookahead info prop_table start_table = let eof_set = IVarSet.singleton info.info_eof in let hash_state = info.info_hash.hash_state_state in let hash_state_item = info.info_hash_state_item in IVarTable.iter (fun _ state -> let core = State.get hash_state state in let items = core.info_state_items in ProdItemSet.iter (fun item -> let item = StateItem.create hash_state_item (state, item) in let prop_entry = prop_table.(StateItem.hash item) in prop_entry.prop_vars <- IVarSet.union prop_entry.prop_vars eof_set) (**) items) start_table (* * The fixpoint is a forward-dataflow problem. * Try to order the states so that dependencies are in * order. Use depth-first-search to find an approximate * order. *) let propagate_order info prop_edges = (* * Build an array of the edges. *) let length = StateItem.length info.info_hash_state_item in let marked = Array.make length false in let graph = match prop_edges with [] -> [||] | edge :: _ -> let graph = Array.make length edge in List.iter (fun edge -> graph.(StateItem.hash edge.prop_edge_src) <- edge) prop_edges; graph in (* * Find the roots if there are any. * If there are none, just pick a node at random. *) let roots nodes = let roots = StateItemSet.fold (fun roots node -> StateItemSet.diff roots graph.(StateItem.hash node).prop_edge_dst) nodes nodes in (* If the graph is cyclic, just choose the first node *) if StateItemSet.is_empty roots then StateItemSet.singleton (StateItemSet.choose nodes) else roots in (* * Produce a sort in DFS order. *) let rec dfs_sort_node (items, next) node = let next = StateItemSet.remove next node in let items, next = dfs_sort_nodes items next graph.(StateItem.hash node).prop_edge_dst in node :: items, next and dfs_sort_nodes items next nodes = StateItemSet.fold (fun items_next node -> if marked.(StateItem.hash node) then items_next else begin marked.(StateItem.hash node) <- true; dfs_sort_node items_next node end) (items, next) nodes in (* * The tree may have disconnected components, * so repeat until done. *) let rec dfs_sort items nodes = if StateItemSet.is_empty nodes then items else let roots = roots nodes in let items, nodes = dfs_sort_nodes items nodes roots in dfs_sort items nodes in (* * Main sort functions. *) let nodes = List.fold_left (fun nodes node -> StateItemSet.add nodes node.prop_edge_src) StateItemSet.empty prop_edges in let items = dfs_sort [] nodes in List.map (fun item -> graph.(StateItem.hash item)) items (* * Now solve the lookahead fixpoint. *) let fixpoint_count = ref 0 let propagate_lookahead prop_table prop_edges = let step () = List.fold_left (fun changed prop_edge -> let { prop_edge_src = src; prop_edge_dst = dst } = prop_edge in let item1 = prop_table.(StateItem.hash src) in if item1.prop_changed then let _ = item1.prop_changed <- false in StateItemSet.fold (fun changed dst -> let item2 = prop_table.(StateItem.hash dst) in let vars2 = item2.prop_vars in let vars2' = IVarSet.union vars2 item1.prop_vars in if IVarSet.cardinal vars2' = IVarSet.cardinal vars2 then changed else begin item2.prop_changed <- true; item2.prop_vars <- vars2'; true end) changed dst else changed) false prop_edges in let rec fixpoint () = incr fixpoint_count; if step () then fixpoint () in fixpoint () (* * Rebuild the transition table. *) let rebuild_trans_table shift_table = StateTable.map (fun goto_table -> IVarTable.map (fun state -> GotoAction state) goto_table) shift_table (* * Construct the LALR(1) table from the LR(0) table. *) let build_lalr_table info start now = let now = time_print "Starting LALR construction" start now in let start_table, shift_table, states = build_state_table info in let now = time_print "State table" start now in let prop_table, prop_edges = build_prop_table info shift_table states in let now = time_print "Propagation table" start now in let () = if !debug_parsetiming then Format.eprintf "Propagate: %d entries, %d edges@." (Array.length prop_table) (List.length prop_edges) in let () = set_start_lookahead info prop_table start_table in let now = time_print "Start state lookaheads" start now in let prop_edges = propagate_order info prop_edges in let now = time_print "Propagation ordering" start now in (* Take the fixpoint *) let () = propagate_lookahead prop_table prop_edges in let now = time_print "Fixpoint" start now in let () = if !debug_parsetiming then Format.eprintf "Fixpoint in %d iterations@." !fixpoint_count in (* Reconstruct the tables *) let trans_table = rebuild_trans_table shift_table in let now = time_print "LALR reconstruction" start now in now, start_table, trans_table, prop_table (************************************************************************ * The info needed to build the grammar. *) let ivar_of_var hash v = IVar.create hash.hash_ivar_state v let ivar_list_of_var_list hash vars = List.map (ivar_of_var hash) vars let iaction_of_action hash action = IAction.create hash.hash_iaction_state action let prod_item_of_prod hash prod = let { prod_name = name; prod_action = action; prod_right = right; prod_prec = pre } = prod in let core = { prod_item_name = ivar_of_var hash name; prod_item_left = []; prod_item_right = ivar_list_of_var_list hash right; prod_item_action = iaction_of_action hash action; prod_item_prec = pre } in ProdItem.create hash.hash_prod_item_state core let info_of_grammar gram start now = (* First and nullable *) let hash = { hash_ivar_state = IVar.create_state (); hash_iaction_state = IAction.create_state (); hash_prod_item_state = ProdItem.create_state (); hash_state_state = State.create_state () } in let prods = VarMTable.fold_all (fun prods v items -> let v = ivar_of_var hash v in let items = List.map (prod_item_of_prod hash) items in IVarTable.add prods v items) IVarTable.empty gram.gram_prod in let nullable = nullable hash prods in let first = first hash prods nullable in let now = time_print "First and nullable sets" start now in (* Initial info *) let start_symbols = VarSet.fold (fun vars v -> IVarSet.add vars (ivar_of_var hash v)) IVarSet.empty gram.gram_start_symbols in let prec_table = VarTable.fold (fun precs v pre -> IVarTable.add precs (ivar_of_var hash v) pre) IVarTable.empty gram.gram_prec in let info = { info_grammar = gram; info_prod = prods; info_start_symbols = start_symbols; info_prec = prec_table; info_nullable = nullable; info_first = first; info_eof = IVar.create hash.hash_ivar_state Arg.eof; info_hash = hash; info_hash_state_item = StateItem.create_state (); (* Temporary placeholders *) info_head_delta = IVarTable.empty; info_head_lookahead = IVarTable.empty } in let now, head_delta, head_lookahead = build_head_table info start now in let now = time_print "Head table" start now in let info = { info with info_head_delta = head_delta; info_head_lookahead = head_lookahead } in now, info (************************************************************************ * Building the parser actions. *) (* * Create the set of nonterminals that have empty production. *) let empty_productions info = let hash = info.info_hash.hash_prod_item_state in IVarTable.fold (fun empties v items -> let rec search items = match items with item :: items -> let core = ProdItem.get hash item in let empty_flag = match core with { prod_item_left = []; prod_item_right = [];_ } -> true | _ -> false in if empty_flag then IVarTable.add empties v item else search items | [] -> empties in search items) IVarTable.empty info.info_prod (* * Get all the reduce productions. * The result is a table * state_item -> lookahead * containing only the reduce items. *) let add_empty_action info actions empties state v look = let item = IVarTable.find empties v in let item = StateItem.create info.info_hash_state_item (state, item) in StateItemTable.filter_add actions item (fun current_look -> match current_look with Some current_look -> lookahead_union current_look look | None -> look) let reduce_actions info empties prop_table = let { info_head_lookahead = look_table ; _} = info in let hash = info.info_hash.hash_prod_item_state in let hash_state_item = info.info_hash_state_item in Array.fold_left (fun actions entry -> let { prop_state_item = state_item; prop_vars = look3; _ } = entry in let state, item = StateItem.get hash_state_item state_item in let core = ProdItem.get hash item in match core.prod_item_right with v :: right when IVarTable.mem look_table v -> (* Add all empty productions *) let look_table = IVarTable.find look_table v in let look2 = lookahead_concat (lookahead info right) (LookAheadConst look3) in let actions = if IVarTable.mem empties v then add_empty_action info actions empties state v look2 else actions in IVarTable.fold (fun actions v look1 -> if IVarTable.mem empties v then let look = lookahead_concat look1 look2 in add_empty_action info actions empties state v look else actions) actions look_table | [] -> (* This production calls for a reduce *) StateItemTable.add actions state_item (LookAheadConst look3) | _ :: _ -> actions) StateItemTable.empty prop_table (* * Error messages. *) let shift_reduce_conflict info state v shift_state reduce_item = let { info_hash = hash ;_ } = info in let { hash_prod_item_state = hash_prod_item ; _} = hash in let pp_print_ivar = pp_print_ivar hash in let pp_print_iaction = pp_print_iaction hash in let reduce_core = ProdItem.get hash_prod_item reduce_item in Format.eprintf "shift/reduce conflict on %a: shift %d, reduce %a@." (**) pp_print_ivar v (State.hash shift_state) pp_print_iaction reduce_core.prod_item_action; if not !debug_parsegen then Format.eprintf "%a@." (pp_print_state info) state; if not !debug_parse_conflict_is_warning then raise (Invalid_argument "Lm_parser.shift_reduce_conflict\n\tset MP_DEBUG=parse_conflict_is_warning to ignore this error") let reduce_reduce_conflict info state v reduce_item action = let { info_hash = hash; _ } = info in let { hash_prod_item_state = hash_prod_item;_ } = hash in let pp_print_ivar = pp_print_ivar hash in let pp_print_iaction = pp_print_iaction hash in let reduce_core = ProdItem.get hash_prod_item reduce_item in Format.eprintf "reduce/reduce conflict on %a: reduce %a, reduce %a@." (**) pp_print_ivar v pp_print_iaction reduce_core.prod_item_action pp_print_iaction action; if not !debug_parsegen then Format.eprintf "%a@." (pp_print_state info) state; if not !debug_parse_conflict_is_warning then raise (Invalid_argument "Lm_parser.reduce_reduce_conflict:\n\tset MP_DEBUG=parse_conflict_is_warning to ignore this error") (* * Process all the reduce actions. * This is finally the stage where we check for conflicts. *) let process_reduce_actions info reduce_actions action_table = let { info_grammar = gram; info_prec = var_prec_table; info_hash = { hash_prod_item_state = hash_prod_item ; _}; _ } = info in let { gram_prec_table = prec_table; _ } = gram in let state_item_hash = info.info_hash_state_item in StateItemTable.fold (fun action_table state_item look -> let look = lookahead_set look in let state, item = StateItem.get state_item_hash state_item in let { prod_item_name = name; prod_item_action = action; prod_item_left = left; prod_item_prec = prec_name; _ } = ProdItem.get hash_prod_item item in let assoc = Precedence.assoc prec_table prec_name in let reduce = ReduceAction (action, name, List.length left) in let actions = StateTable.find action_table state in let actions = IVarSet.fold (fun actions v -> try match IVarTable.find actions v with GotoAction id -> (* Shift/reduce conflict *) let cmp = try Precedence.compare prec_table prec_name (IVarTable.find var_prec_table v) with Not_found -> 0 in if cmp < 0 then actions else if cmp = 0 then match assoc with LeftAssoc -> IVarTable.add actions v reduce | RightAssoc -> actions | NonAssoc -> IVarTable.add actions v ErrorAction | NoneAssoc -> shift_reduce_conflict info state v id item; actions else IVarTable.add actions v reduce | ReduceAction (action2, _, _) -> (* Reduce/reduce conflict *) reduce_reduce_conflict info state v item action2; actions | ErrorAction -> raise (Invalid_argument "reduce_action") with Not_found -> IVarTable.add actions v reduce) actions look in StateTable.add action_table state actions) action_table reduce_actions (* * If a state has only one production, * and that is a reduce production, we can do * the reduce without lookahead. *) let reduce_early info prop_table state items = if ProdItemSet.cardinal items = 1 then let item = ProdItemSet.choose items in match ProdItem.get info.info_hash.hash_prod_item_state item with { prod_item_right = []; prod_item_action = action; prod_item_name = name; prod_item_left = left; _ } -> let state_item = StateItem.create info.info_hash_state_item (state, item) in let lookahead = prop_table.(StateItem.hash state_item).prop_vars in if IVarSet.cardinal lookahead = 1 && IVarSet.choose lookahead = info.info_eof then ReduceAccept (action, name, List.length left) else ReduceNow (action, name, List.length left) | _ -> ReduceNone else ReduceNone (************************************************************************ * Constructing the PDA. *) (* * Flatten a production state to a pda description. *) let pda_info_of_items info prop_table state items = let { info_first = first; info_hash_state_item = hash_state_item; info_hash = { hash_prod_item_state = hash_prod_item;_ }; _ } = info in let items, next = ProdItemSet.fold (fun (items, next) prod_item -> let core = ProdItem.get hash_prod_item prod_item in let { prod_item_left = left; prod_item_right = right; _ } = core in let item = { pda_item_left = left; pda_item_right = right } in let items = item :: items in let next = match right with v :: _ -> let next2 = try IVarTable.find first v with Not_found -> IVarSet.singleton v in IVarSet.union next next2 | [] -> let state_item = StateItem.create hash_state_item (state, prod_item) in let lookahead = prop_table.(StateItem.hash state_item).prop_vars in IVarSet.union next lookahead in items, next) ([], IVarSet.empty) items in { pda_items = items; pda_next = next } let pda_action action = match action with GotoAction state -> GotoAction (State.hash state) | ReduceAction _ | ErrorAction as action -> action let pda_delta table = IVarTable.map pda_action table (* * Find the start state for a production. *) let create_core gram = let start = time_start () in let now = start in let now, info = info_of_grammar gram start now in let now, start_table, trans_table, prop_table = build_lalr_table info start now in let empty_table = empty_productions info in let reduce_actions = reduce_actions info empty_table prop_table in let now = time_print "Reduce productions" start now in let trans_table = process_reduce_actions info reduce_actions trans_table in let now = time_print "Shift/reduce table" start now in (* Build the PDA states *) let table = State.map_array (fun state core -> let { info_state_items = items; _ } = core in { pda_delta = pda_delta (StateTable.find trans_table state); pda_reduce = reduce_early info prop_table state items; pda_info = pda_info_of_items info prop_table state items }) info.info_hash.hash_state_state in let start_table = IVarTable.map State.hash start_table in let _now = time_print "PDA construction" start now in { pda_start_states = start_table; pda_states = table; pda_hash = info.info_hash } let create gram = let start = time_start () in let pda = create_core gram in let _ = time_print "Grammar total" start start in pda (************************************************************************ * PDA execution. *) (* * Execute a semantic action. *) let loc_of_stack stack = match stack with | (_, loc, _) :: _ -> loc | [] -> Lm_location.bogus_loc "null" let rec collect_args state args loc1 stack i = if i = 0 then state, loc1, args, stack else match stack with (state, loc2, arg) :: stack -> collect_args state (arg :: args) ( Lm_location.union_loc loc1 loc2) stack (pred i) | [] -> raise (Invalid_argument "semantic_action: stack is empty") let semantic_action hash eval arg action stack state tokens = let loc = loc_of_stack stack in let state, loc, args, stack = collect_args state [] loc stack tokens in let () = if !debug_parse then Format.eprintf "Calling action %a@." (pp_print_iaction hash) action in let arg, value = eval arg (IAction.get hash.hash_iaction_state action) loc args in let () = if !debug_parse then Format.eprintf "Called action %a@." (pp_print_iaction hash) action in state, arg, loc, value, stack (* * Exceptions. *) let parse_error loc hash run _stack state (v : ivar) = let { pda_info = { pda_items = items; pda_next = next;_ }; _ } = run.run_states.(state) in let pp_print_ivar = pp_print_ivar hash in let buf = Format.str_formatter in Format.fprintf buf "@[Syntax error on token %a" pp_print_ivar v; Format.fprintf buf "@ @[Current state:"; List.iter (fun item -> let { pda_item_left = left; pda_item_right = right } = item in Format.fprintf buf "@ @["; Lm_list_util.rev_iter (fun v -> Format.fprintf buf "@ %a" pp_print_ivar v) left; Format.fprintf buf "@ ."; List.iter (fun v -> Format.fprintf buf "@ %a" pp_print_ivar v) right; Format.fprintf buf "@]") items; Format.fprintf buf "@ @[The next possible tokens are:"; IVarSet.iter (fun v -> Format.fprintf buf "@ %a" pp_print_ivar v) next; Format.fprintf buf "@]@]"; raise (ParseError (loc, Format.flush_str_formatter ())) (* * Execution. * * The stack contains (state * value) pairs, where the * state is the state of the machine when that token was pushed. * * !!!CAUTION!!! Keep the number of arguments 6 or less so * that these functions can be tail recursive. *) let fst3 (v, _, _) = v let pda_loop hash run arg start = let rec pda_lookahead arg stack state tok = let { pda_delta = delta; _ } = run.run_states.(state) in let v, loc, x = tok in match (try IVarTable.find delta v with Not_found -> parse_error loc hash run stack state v) with GotoAction new_state -> if !debug_parse then Format.eprintf "State %d: token %a: shift %d@." state (pp_print_ivar hash) v new_state; pda_no_lookahead arg ((state, loc, x) :: stack) new_state | ReduceAction (action, name, tokens) -> if !debug_parse then Format.eprintf "State %d: reduce %a@." state (pp_print_iaction hash) action; let state, arg, loc, x, stack = semantic_action hash run.run_eval arg action stack state tokens in pda_goto_lookahead arg stack (state, loc, x) name tok | ErrorAction -> parse_error loc hash run stack state v and pda_goto_lookahead arg stack state_loc_x name tok = let state, loc, _x = state_loc_x in let () = if !debug_parse then Format.eprintf "State %d: Goto lookahead: production %a@." (**) state (pp_print_ivar hash) name in let action = try IVarTable.find run.run_states.(state).pda_delta name with Not_found -> parse_error loc hash run stack state name in match action with GotoAction new_state -> if !debug_parse then Format.eprintf "State %d: production %a: goto %d (lookahead %a)@." (**) state (pp_print_ivar hash) name new_state (pp_print_ivar hash) (fst3 tok); let stack = state_loc_x :: stack in pda_lookahead arg stack new_state tok | ErrorAction | ReduceAction _ -> Format.eprintf "pda_goto_no_lookahead: illegal action: %a@." (pp_print_pda_action hash) action; raise (Invalid_argument "pda_goto_lookahead: illegal action") and pda_no_lookahead arg stack state = match run.run_states.(state).pda_reduce with ReduceNow (action, name, tokens) -> if !debug_parse then Format.eprintf "State %d: ReduceNow: %a@." state (pp_print_iaction hash) action; let state, arg, loc, x, stack = semantic_action hash run.run_eval arg action stack state tokens in pda_goto_no_lookahead arg stack (state, loc, x) name | ReduceAccept (action, _, tokens) -> if !debug_parse then Format.eprintf "State %d: ReduceAccept: %a@." state (pp_print_iaction hash) action; let _, arg, _, x, _ = semantic_action hash run.run_eval arg action stack state tokens in arg, x | ReduceNone -> let v, loc, arg, x = run.run_lexer arg in let v = IVar.create hash.hash_ivar_state v in let () = if !debug_parse then Format.eprintf "State %d: Read token: %a@." state (pp_print_ivar hash) v in pda_lookahead arg stack state (v, loc, x) and pda_goto_no_lookahead arg stack state_loc_x name = let state, loc, x = state_loc_x in let action = try IVarTable.find run.run_states.(state).pda_delta name with Not_found -> parse_error loc hash run stack state name in match action with GotoAction new_state -> if !debug_parse then Format.eprintf "State %d: production %a: goto %d (no lookahead)@." (**) state (pp_print_ivar hash) name new_state; let stack = (state, loc, x) :: stack in pda_no_lookahead arg stack new_state | ErrorAction | ReduceAction _ -> Format.eprintf "pda_goto_no_lookahead: illegal action: %a@." (pp_print_pda_action hash) action; raise (Invalid_argument "pda_goto_no_lookahead") in pda_no_lookahead arg [] start let parse pda start lexer eval arg = let { pda_states = states; pda_start_states = start_states; pda_hash = hash } = pda in let run = { run_states = states; run_lexer = lexer; run_eval = eval } in let start = try IVarTable.find start_states start with Not_found -> raise (Failure ("not a start symbol: " ^ string_of_ivar hash start)) in try pda_loop hash run arg start with Not_found -> raise (Failure "syntax error") (************************************************************************ * Wrappers. *) let empty = { parse_grammar = empty_grammar; parse_pda = None } let add_start info sym = let gram = add_start info.parse_grammar sym in { parse_grammar = gram; parse_pda = None } let get_start info = VarSet.fold (fun vars v -> v :: vars) [] (info.parse_grammar.gram_start_symbols) let prec_min = Precedence.prec_min let prec_max = Precedence.prec_max let add_assoc info pre assoc = let { parse_grammar = gram; _ } = info in let { gram_prec_table = prec_table ; _} = gram in let prec_table = Precedence.add_assoc prec_table pre assoc in let gram = { gram with gram_prec_table = prec_table } in let info = { parse_grammar = gram; parse_pda = None } in info let create_prec_lt info pre assoc = let { parse_grammar = gram ; _} = info in let { gram_prec_table = prec_table; _ } = gram in let prec_table, pre = Precedence.create_prec_lt prec_table pre assoc in let gram = { gram with gram_prec_table = prec_table } in let info = { parse_grammar = gram; parse_pda = None } in info, pre let create_prec_gt info pre assoc = let { parse_grammar = gram ; _} = info in let { gram_prec_table = prec_table ; _} = gram in let prec_table, pre = Precedence.create_prec_gt prec_table pre assoc in let gram = { gram with gram_prec_table = prec_table } in let info = { parse_grammar = gram; parse_pda = None } in info, pre let add_prec info pre v = let gram = add_prec info.parse_grammar pre v in { parse_grammar = gram; parse_pda = None } let find_prec info v = find_prec info.parse_grammar v let add_production info action name rhs pre = let gram = add_production info.parse_grammar action name rhs pre in { parse_grammar = gram; parse_pda = None } let remove_production info action = let gram = remove_production info.parse_grammar action in { parse_grammar = gram; parse_pda = None } let union info1 info2 = let changed, gram = union_grammar info1.parse_grammar info2.parse_grammar in if changed then { parse_grammar = gram; parse_pda = None } else info1 let pda_of_info info = match info.parse_pda with Some pda -> pda | None -> let pda = create info.parse_grammar in info.parse_pda <- Some pda; pda let parse info start lexer eval = let pda = pda_of_info info in let start = IVar.create pda.pda_hash.hash_ivar_state start in parse pda start lexer eval let compile info = ignore (pda_of_info info) let build info debug = let prev_debug = !debug_parse in let () = debug_parse := debug in let pda = create info.parse_grammar in debug_parse := prev_debug; info.parse_pda <- Some pda let pp_print_parser buf info = pp_print_grammar buf info.parse_grammar let hash info = Hashtbl.hash_param max_int max_int info.parse_grammar end (* * Default precedence module. *) module ParserPrecedence : PrecedenceArg = struct (* * A precedence has a name and associativity. * The integer gives the *name* of a precedence, * not the actual priority. *) type precedence = int module PrecTable = Lm_int_set.IntTable;; type t = (assoc * int) PrecTable.t (* * Degenerate precedences. *) let prec_min = 0 let prec_max = 1 let empty = let prec_table = PrecTable.empty in let prec_table = PrecTable.add prec_table prec_min (NoneAssoc, 0) in let prec_table = PrecTable.add prec_table prec_max (NoneAssoc, 1) in prec_table (* * Check that the associativity matches. *) let add_assoc table pre assoc = let () = try let assoc', _ = PrecTable.find table pre in if assoc' <> assoc then raise (Failure "ParserPrecedence.add_assoc: associativities do not match") with Not_found -> raise (Failure "ParserPrecedence.add_assoc: precedence is not defined") in table (* * Shift all the precedence levels at least the given level * up by one. *) let prec_shift table prio = PrecTable.map (fun (assoc, prio2) -> let prio = if prio2 >= prio then succ prio2 else prio2 in assoc, prio) table (* * Create a new precedence level after the given one. *) let create_prec_lt table pre assoc = let index = PrecTable.cardinal table in let _, prio = PrecTable.find table pre in let table = prec_shift table prio in let table = PrecTable.add table index (assoc, prio) in table, index let create_prec_gt table pre assoc = let index = PrecTable.cardinal table in let _, prio = PrecTable.find table pre in let table = prec_shift table (succ prio) in let table = PrecTable.add table index (assoc, succ prio) in table, index (* * Get the associativity of a precedence operator. *) let assoc table pre = fst (PrecTable.find table pre) (* * Compare two precedences. *) let compare table pre1 pre2 = let _, prio1 = PrecTable.find table pre1 in let _, prio2 = PrecTable.find table pre2 in prio1 - prio2 (* * Print the precedence. *) let pp_print_prec table buf pre = let assoc, prio = PrecTable.find table pre in Format.fprintf buf "%a, %d" pp_print_assoc assoc prio end omake-0.10.3/src/front/lm_hash_cons.ml0000644000175000017500000000317213177364665016246 0ustar gerdgerd module Make (Arg : sig type t (* For debugging *) val debug : string (* The client needs to provide hash and comparison functions *) val hash : t -> int val compare : t -> t -> int end ) = struct (* %%MAGICBEGIN%% *) type t = int module KeyTable = Lm_map.LmMake (Arg);; (* bi-directions. *) type state = { mutable keys : int KeyTable.t; mutable ints : Arg.t array } (* %%MAGICEND%% *) let create_state () = { keys = KeyTable.empty; ints = [||] } let length state = KeyTable.cardinal state.keys let set state (i : int) (x : Arg.t) = let table = state.ints in let len = Array.length table in if len = 0 then state.ints <- Array.make 32 x else if i = len then let table2 = Array.make (len * 2) x in Array.blit table 0 table2 0 len; state.ints <- table2 else table.(i) <- x let create state (item : Arg.t) : int = try KeyTable.find state.keys item with Not_found -> let index = KeyTable.cardinal state.keys in state.keys <- KeyTable.add state.keys item index; set state index item ; index let get state (index : int) : Arg.t = state.ints.(index) let hash index = index let compare (index1 : int) index2 = Pervasives.compare index1 index2 let map_array f state = Array.mapi f (Array.sub state.ints 0 (KeyTable.cardinal state.keys)) let fold f x state = let len = KeyTable.cardinal state.keys in let rec fold i x = if i = len then x else fold ( i + 1) (f x i) in fold 0 x end omake-0.10.3/src/front/lm_glob.mli0000644000175000017500000000600213177364666015371 0ustar gerdgerd(* open Lm_lexer. *) type glob_option = | GlobNoBraces (* Do not perform csh-style brace expansion *) | GlobNoTilde (* Do not perform tilde-expansion *) | GlobNoEscape (* The \ character does not escape special characters *) | GlobNoCheck (* If an expansion fails, return the expansion literally *) | GlobIgnoreCheck (* If an expansion fails, it expands to nothing *) | GlobDot (* Allow wildcards to match filenames with a leading . *) | GlobOnlyFiles (* Return only non-directories in the result *) | GlobOnlyDirs (* Return only directories in the result *) | GlobCVSIgnore (* Ignore files as specified by .cvsignore files *) | GlobIgnore of string list (* Ignore the files that match the pattern *) | GlobAllow of string list (* Allow only files that match the pattern *) | GlobIgnoreFun of (string -> bool) (* Ignore the files specified by the function *) | GlobAllowFun of (string -> bool) (* Allow only the files specified by the function *) | GlobHomeDir of string (* Home directory for ~ expansion *) | GlobProperSubdirs (* Include only proper subdirs in listing *) type glob_options val create_options : glob_option list -> glob_options val default_glob_options : glob_options (* * The initial home directory for tilde expansion. * The globber does its best to figure this out. *) val home_dir : string (* * Get a list of all the users in the system. * On non-unix systems, returns the empty list. *) val getusers : unit -> string list (* * Get the home directory for a user. *) val gethomedir : string -> string (* * Try to collapse a filename. * Tilde-expansion will invert this process. *) val tilde_collapse : string -> string (* * Glob detection and escaping. *) val is_glob_string : glob_options -> string -> bool val glob_add_escaped : glob_options -> Buffer.t -> string -> unit (* * The glob function returns two lists: * 1. a list of directories * 2. a list of files of other types * * The second argument to the glob and the glob_argv functions is the directory * where to perform expansion. If the glob pattern is relative, the results are * left relative (to that directory) as well. * * Raises Failure if the syntax is ill-formed. *) val glob : glob_options -> string -> string list -> string list * string list (* * Glob a command line. * Preserves the argument ordering. *) val glob_argv : glob_options -> string -> string list -> string list (* * Get the entries in a directory. * * list_dirs root dirs * root: the directory prefix, not appended to the output strings * dirs: the directories to list *) val list_dirs : glob_options -> string -> string list -> string list * string list val list_dirs_rec : glob_options -> string -> string list -> string list * string list val subdirs_of_dirs : glob_options -> string -> string list -> string list (* * Utilities. *) val regex_of_shell_pattern : glob_options -> string -> Lm_lexer.LmStr.t omake-0.10.3/src/front/lm_lexer.mli0000644000175000017500000001150713177364666015573 0ustar gerdgerd(* * Debug flags. *) val debug_lexgen : bool ref val debug_lex : bool ref (* * The lexer takes an input stream as an argument. *) module type LexerInput = sig (* * Input channel is a stream of integers. * Usually these are just the ASCII codes for characters. *) type t (* * The channel has two special characters. * bof: the beginning of file * eof: the end of file. *) val bof : int val eof : int (* * The next function returns the next character in the input stream. *) val lex_next : t -> int (* * The pos function returns the current position of * the input buffer within the lexeme * (used for collecting \( ... \) arguments. *) val lex_pos : t -> int (* * The lexer will call start when it begins lexing. * The integer should be the *previous* character in the * input channel, or bof if at the beginning. *) val lex_start : t -> int (* * In some cases, the lexer may want to restart scanning * from a previous point. If so, it will call this function * to reset the start point. *) val lex_restart : t -> int -> unit (* * When the lexer is done, it calls lex_stop with * the number of characters in the final lexeme. Note * that this can cause data to be pushed back onto the input stream. *) val lex_stop : t -> int -> unit (* * Before calling lex_stop, the lexer may ask for the * lexeme as a string. The integer is the number of * characters in the lexeme, the same as the argument * to lex_stop. *) val lex_string : t -> int -> string val lex_substring : t -> int -> int -> string val lex_loc : t -> int -> Lm_location.t end (* * Semantic actions. *) module type LexerAction = sig (* * Values of action type *must* be comparable with =, * hopefully quickly. * * For example, functions are not allowed. * If you want a function, you should make an array of functions, * and use the index for the action name. *) type action (* For debugging *) val pp_print_action : action Lm_printf.t (* For creating sets and tables *) val hash : action -> int val compare : action -> action -> int (* * You can use the function to decide which clauses take * precedence for a match of equal length. The function * gets two clause numbers. If you use the min function, * then you get the first clause that matched. If you * use the max function, you get the second clause that * matched. *) val choose : int -> int -> int end module MakeLexer (Input : LexerInput) (Action : LexerAction) : sig open Action type t (* Return values from the searchto function *) type searchto_info = LexEOF | LexSkipped of Lm_location.t * string | LexMatched of action * Lm_location.t * string * string * string list (* The empty lexer accepts the empty language *) val empty : t (* Add a clause, specified as a regular expression *) val add_clause : t -> action -> string -> int * t (* Remove a clause by action name *) val remove_clause : t -> action -> t (* * Union of two lexers. * The union assumes that actions with the same name * have the same regular expression. *) val union : t -> t -> t (* * Compile the machine if not already compiled. * This is entirely optional. It is here just in case you * want to expand the machine eagerly (for example before * marshaling it to a file). *) val compile : t -> unit (* * Print the lexer. * This is mainly for debugging. *) val pp_print_lexer : t Lm_printf.t (* * Hash code for the lexer. *) val hash : t -> int (* * Now match against an input channel. * The result is (clause, lexeme, args) * clause: the index of the clause that matched * lexeme: the entire string that matched * args: the arguments for \(...\) patterns. *) val lex : t -> Input.t -> action * Lm_location.t * string * string list (* * Search for the first occurrence of a match. * Return the unmatched data that was skipped as well. * (action, skipped, matched, args) * This will not read past EOF. *) val search : t -> Input.t -> (action * Lm_location.t * string * string * string list) option (* * The searchto function is similar, but if it doesn't detect a match, * it returns the text to the end of the channel. *) val searchto : t -> Input.t -> searchto_info (* * Just check if a string matches. *) val matches : t -> Input.t -> bool end (* * Str module replacement. *) module LmStr : sig type t (* * Construct a regular expression from a string. *) val regexp : string -> t (* * Check for a match. *) val string_match : t -> string -> int -> bool end omake-0.10.3/src/front/lm_parser.mli0000644000175000017500000001114013177364666015741 0ustar gerdgerdopen! Lm_printf val debug_parse : bool ref val debug_parsegen : bool ref val debug_parsetiming : bool ref val debug_parse_conflict_is_warning : bool ref (* * Associativity and precedence. *) type assoc = LeftAssoc | RightAssoc | NonAssoc | NoneAssoc val pp_print_assoc : assoc Lm_printf.t module type PrecedenceArg = sig type t type precedence (* Precedence control *) val prec_min : precedence val prec_max : precedence (* Precedence tables *) val empty : t val create_prec_lt : t -> precedence -> assoc -> t * precedence val create_prec_gt : t -> precedence -> assoc -> t * precedence (* Print a precedence *) val pp_print_prec : t -> precedence Lm_printf.t (* Comparison *) val add_assoc : t -> precedence -> assoc -> t val assoc : t -> precedence -> assoc val compare : t -> precedence -> precedence -> int (* Tables and sets *) module PrecTable : Lm_map_sig.LmMap with type key = precedence end (* Default implementation *) module ParserPrecedence : PrecedenceArg exception ParseError of Lm_location.t * string (* * The parser is parameterized over symbol and action names. *) module type ParserArg = sig (* Variable names: the names of terminals and nonterminals *) type symbol (* A symbol to represent eof *) val eof : symbol (* For debugging *) val to_string : symbol -> string val pp_print_symbol : symbol Lm_printf.t (* Sets and tables *) val hash_symbol : symbol -> int val compare_symbol : symbol -> symbol -> int (* Names of semantic actions *) type action (* For debugging *) val pp_print_action : action Lm_printf.t (* For set and table building *) val hash_action : action -> int val compare_action : action -> action -> int end module MakeParser (Arg : ParserArg) (Precedence : PrecedenceArg) : sig open Arg open Precedence (* Grammar operations *) type t type ('a, 'b) lexer = 'a -> symbol * Lm_location.t * 'a * 'b type ('a, 'b) eval = 'a -> (* The argument *) action -> (* The name of the action *) Lm_location.t -> (* Location of the production *) 'b list -> (* The arguments to the action *) 'a * 'b (* The result of the semantic action *) (* The empty grammar accepts the empty language *) val empty : t (* * Add a start symbol. There can be more than one start symbol, * but parsing can only be performed for start variables. *) val add_start : t -> symbol -> t val get_start : t -> symbol list (* Precedence control *) val prec_min : precedence val prec_max : precedence val create_prec_lt : t -> precedence -> assoc -> t * precedence val create_prec_gt : t -> precedence -> assoc -> t * precedence val add_assoc : t -> precedence -> assoc -> t val add_prec : t -> precedence -> symbol -> t val find_prec : t -> symbol -> precedence (* Add a production *) val add_production : t -> (* The initial grammar *) action -> (* The name of the semantic action *) symbol -> (* The left-hand-side of the production *) symbol list -> (* The right-hand-side of the production *) symbol option -> (* Optional precedence is the same as that of the symbol *) t (* Delete a production based on the name of the semantic action *) val remove_production : t -> (* The initial grammar *) action -> (* The name of the semantic action *) t (* * Take the union of two parsers. * Assumes that productions with the same action name are the same. *) val union : t -> t -> t (* * Build the parser if it isn't already built. * This step is entirely optional. Call it if you want * to check for errors in the current grammar. *) val compile : t -> unit (* * Hash code for the parser. *) val hash : t -> int (* Force a parser build, possibly in debug mode *) val build : t -> bool -> unit (* Print the grammar *) val pp_print_parser : t Lm_printf.t (* Now the actual machine *) val parse : t -> (* The machine *) symbol -> (* The start symbol *) ('a, 'b) lexer -> (* The lexer *) ('a, 'b) eval -> (* The semantic action evaluator *) 'a -> (* The argument *) 'a * 'b (* The result *) end omake-0.10.3/src/front/lm_hash_cons.mli0000644000175000017500000000235313177364666016420 0ustar gerdgerd (** A generic hash module to make *comparisons faster.* This version uses a state for hash-consing. Table-based hashing. A basic table for adding a hash code to every element. Nothing else is done, so comparisons are still slow. This table is safe to marshal. Items are represented by their indexes into a table. This is the fastest implementation, but it is not safe to marshal unless you also marshal the table. If you need a version that is safe to marshal, consider using the HashMarshal below. *) module Make (Arg : sig type t (* For debugging *) val debug : string (* The client needs to provide hash and comparison functions *) val hash : t -> int val compare : t -> t -> int end ) : sig type state type t (* States *) val create_state : unit -> state val length : state -> int (* Normal creation *) val create : state -> Arg.t -> t val get : state -> t -> Arg.t (* Hash code *) val hash : t -> int (* Comparison *) val compare : t -> t -> int (* Map over an array of hash codes *) val map_array : (t -> Arg.t(* elt *) -> 'a) -> state -> 'a array (* Fold over all of the items *) val fold : ('a -> t -> 'a) -> 'a -> state -> 'a end omake-0.10.3/src/magic/0000755000175000017500000000000013177364666013205 5ustar gerdgerdomake-0.10.3/src/magic/OMakefile0000644000175000017500000000524713177364665014773 0ustar gerdgerd# # Calculate magic numbers for various binary formats # OCAMLINCLUDES[] += ../libmojave ../front # # Magic number generator # OCAML_LIBS[] = ../libmojave/lm ../front/frt OCAML_CLIBS[] = ../clib/clib MakeOCamlProgram(omake_gen_magic, omake_gen_magic) ######################################################################## # Scanning files for magic numbers. # CACHE_MAGIC_FILES[] = ../libmojave/lm_filename_util.ml ../libmojave/lm_hash.ml ../libmojave/lm_location.ml ../libmojave/lm_map.ml ../libmojave/lm_position.ml ../libmojave/lm_set.ml ../libmojave/lm_symbol.ml ../ir/omake_value_type.ml ../ir/omake_cache.ml ../ir/omake_cache_type.ml ../ir/omake_node.ml ../env/omake_command_digest.ml OMC_MAGIC_FILES[] = ../libmojave/lm_filename_util.ml ../libmojave/lm_hash.ml ../libmojave/lm_location.ml ../libmojave/lm_symbol.ml ../libmojave/lm_map.ml ../libmojave/lm_set.ml ../ir/omake_node.ml ../ir/omake_ir.ml OMO_MAGIC_FILES[] = ../libmojave/lm_filename_util.ml ../libmojave/lm_hash.ml ../front/lm_lexer.ml ../libmojave/lm_location.ml ../libmojave/lm_map.ml ../front/lm_parser.ml ../libmojave/lm_position.ml ../libmojave/lm_set.ml ../libmojave/lm_symbol.ml ../ir/omake_value_type.ml ../ir/omake_cache_type.ml ../ir/omake_ir.ml ../ir/omake_node.ml ../env/omake_env.ml GENMAGIC_DEPS[] = $(CACHE_MAGIC_FILES) $(OMC_MAGIC_FILES) $(OMO_MAGIC_FILES) $(VERSION_TXT) MAGIC_FILES =\ --cache-files $(CACHE_MAGIC_FILES)\ --omc-files $(OMC_MAGIC_FILES)\ --omo-files $(OMO_MAGIC_FILES) # # Generate the file # omake_magic.ml: omake_gen_magic$(EXE) $(GENMAGIC_DEPS) ./omake_gen_magic -o $@ --lib $(LIBDIR) --version $(VERSION_TXT) --default_save_interval $(DEFAULT_SAVE_INTERVAL) --var "omake_cc=$(CC)" --var "omake_cflags=$(CFLAGS)" --var "omake_ccomptype=$(CCOMPTYPE)" --magic $(MAGIC_FILES) MakeOCamlLibrary(magic, omake_magic) clean: $(CLEAN) omake_magic.ml .*.magic omake_gen_magic$(EXE) omake_gen_magic.opt omake_gen_magic.run ######################################################################## # Generate the Makefile # MAKEFILE_TEXT += $""" GENMAGIC_DEPS = $(basename $(GENMAGIC_DEPS)) MAGIC_FILES =\ --cache-files $(basename $(CACHE_MAGIC_FILES))\ --omc-files $(basename $(OMC_MAGIC_FILES))\ --omo-files $(basename $(OMO_MAGIC_FILES)) omake_magic.ml: omake_gen_magic$$(EXE) $$(GENMAGIC_DEPS) $$(DOT)omake_gen_magic -o $$@ --version version.txt --var "omake_cc=$$(CC)" --var "omake_cflags=$$(CFLAGS)" --var "omake_ccomptype=$$(CCOMPTYPE)" --magic $$(MAGIC_FILES) """ MakeDontLink(omake_magic.ml) MakeMakefile() omake-0.10.3/src/magic/omake_gen_magic.ml0000644000175000017500000001765613177364666016643 0ustar gerdgerd(* * Generate magic numbers. *) type mode = | CacheFiles | OmcFiles | OmoFiles | NoFiles (* Get the version from the version.txt file. *) let read_version_from_file inx = let line = Lm_string_util.trim (input_line inx) in if line = "" then raise End_of_file; line let read_version version_txt : string = let file = version_txt in let inx = open_in file in let version = try read_version_from_file inx with End_of_file -> Printf.eprintf "The %s file does not contain a version number\n" file; flush stderr; exit 1 in close_in inx; if Lm_string_util.contains_any version "()$\" " then version else if String.contains version '-' then let dash = String.index version '-' in let release = String.sub version (dash + 1) ((String.length version) - dash - 1) in if String.length release > 4 && String.sub release 0 4 = "0.rc" then let release = String.sub release 4 ((String.length release) - 4) in Printf.sprintf "%s (release candidate %s)" (String.sub version 0 dash) release else Printf.sprintf "%s (release %s)" (String.sub version 0 dash) release else version ^ " (development snapshot)" let digest_len = 4 + String.length (Digest.string "hello world") let shorten_version s = if Lm_string_util.contains_any s " -" then String.sub s 0 (Lm_string_util.index_set s " -") else s (* Figure out if the line is a magic directive. *) (* {[ magic_line_type "(\* %%MAGICEND%% *\)";; `END magic_line_type "(* %%MAGICBEGIN%% *)";; `Begin ]} *) let magic_line_type line = let gbuf = Buffer.create 200 in let len = String.length line in let rec loop mode i = if i <> len then let c = line.[i] in if c = '%' then match mode with | `Idle -> loop `Start (i+1) | `Start -> loop `Scanning (i+1) | `Scanning -> () else begin if mode = `Scanning then Buffer.add_char gbuf c; loop mode (i+1) end in let () = loop `Idle 0 in let code = Buffer.contents gbuf in Buffer.clear gbuf; begin match code with | "MAGICBEGIN" -> `Begin | "MAGICEND" -> `End | _ -> `None end let copy_magic_file outx inp : unit = let rec copy inx magic_flag = let line = input_line inx in match magic_line_type line with | `Begin -> copy inx true | `End -> copy inx false | `None -> if magic_flag then begin output_string outx line; output_char outx '\n' end; copy inx magic_flag in match open_in inp with | exception Sys_error _ -> Printf.eprintf "Can't open %s\n" inp; flush stderr; exit 1 | inx -> try copy inx false with End_of_file -> close_in inx let omake_magic (buf : out_channel) version_txt default_save_interval libdir cache_files omc_files omo_files vars : unit = let digest_files filename code filenames = match open_out_bin filename with | exception Sys_error _ -> Printf.eprintf "Can't open temporary_file %s\n" filename; flush stderr; exit 2 | outx -> let digest = List.iter (copy_magic_file outx) filenames; close_out outx; Digest.file filename in String.escaped (code ^ digest) in let version = read_version version_txt in let tm = Unix.(localtime (time ())) in Printf.fprintf buf {| let default_save_interval = %F let input_magic inx = let s = Bytes.make %d ' ' in really_input inx s 0 %d; Bytes.to_string s let output_magic = output_string let cache_magic = "%s" let ir_magic = "%s" let obj_magic = "%s" let lib_dir = "%s" let version = "%s" let version_message = "OMake %s:\\n\\tbuild [%s %s %d %02d:%02d:%02d %d]\\n\\ton %s" |} default_save_interval digest_len digest_len (digest_files ".cache.magic" ".odb" cache_files) (digest_files ".omc.magic" ".omc" omc_files) (digest_files ".omo.magic" ".omo" omo_files) (String.escaped libdir) (String.escaped (shorten_version version)) (String.escaped version) [|"Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"|].(tm.tm_wday) [|"Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec"|].(tm.tm_mon) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec (tm.tm_year + 1900) (String.escaped (Unix.gethostname ())); List.iter (fun (name,value) -> Printf.fprintf buf "let %s = %S\n" name value ) vars; flush buf let omake_root buf version_txt name = (* Copy a file from input to output. *) let copy_file buf inx = let rec copy () = let line = input_line inx in output_string buf line; output_char buf '\n'; copy () in try copy () with End_of_file -> () in let version = shorten_version (read_version version_txt) in let version = if Lm_string_util.contains_any version "()$\" " then Printf.sprintf "$'''%s'''" version else version in let inx = open_in name in Printf.fprintf buf "#\n# Required version of omake\n#\nOMakeVersion(%s, %s)\n\n" version version; copy_file buf inx; Printf.fprintf buf "\n"; close_out buf; close_in inx let libdir = ref None let version_txt = ref "version.txt" let mode = ref NoFiles let make_magic = ref false let make_root = ref None let output_file = ref None let cache_files = ref [] let omc_files = ref [] let omo_files = ref [] let default_save_interval = ref 15.0 let vars = ref [] let anon s = let p = match !mode with | CacheFiles -> cache_files | OmcFiles -> omc_files | OmoFiles -> omo_files | NoFiles -> Printf.eprintf "You specified an anonymous file. Use --help for help."; exit 3 in p := s :: !p let spec : (string * Arg.spec * string) list = ["--magic", Set make_magic, "generate the omake_magic.ml file"; "--cache-files", Unit (fun () -> mode := CacheFiles), "specify the magic files for the cache magic number"; "--omc-files", Unit (fun () -> mode := OmcFiles), "specify the files to scan for the IR magic number"; "--omo-files", Unit (fun () -> mode := OmoFiles), "specify the files to scan for the object magic number"; "--version", String (fun s -> version_txt := s), "specify the version.txt file"; "-o",String (fun s -> output_file := Some s), "set the output file"; "--lib", String (fun s -> libdir := Some s), "specify the location of the library directory"; "--root", String (fun s -> make_root := Some s), "generate the OMakeroot file"; "--default_save_interval", Float (fun f -> default_save_interval := f), "specify the default .omakedb save interval"; "--var", String (fun s -> let (name,value) = try let p = String.index s '=' in (String.sub s 0 p, String.sub s (p+1) (String.length s - p - 1) ) with Not_found -> failwith ("bad --var: " ^ s) in vars := (name,value) :: !vars ), "another variable, format name=value"; ] let usage = "Generate special files" (************************************************************************ * Main function. *) let main () = Arg.parse spec anon usage; let buf = match !output_file with | Some name -> open_out_bin name | None -> raise (Invalid_argument "use the -o option to specify an output file") in let libdir = match !libdir with | Some s -> Filename.concat s "omake" | None -> Filename.concat (Filename.dirname (Unix.getcwd ())) "lib" in if !make_magic then omake_magic buf !version_txt !default_save_interval libdir !cache_files !omc_files !omo_files !vars else match !make_root with | Some name -> omake_root buf !version_txt name | None -> Arg.usage spec usage; exit 2 let _ = Printexc.catch main () omake-0.10.3/src/build/0000755000175000017500000000000013177364666013224 5ustar gerdgerdomake-0.10.3/src/build/OMakefile0000644000175000017500000000064113177364665015003 0ustar gerdgerdOCAMLINCLUDES[] += ../libmojave ../front ../magic ../ir ../env ../exec ../shell ../eval FILES[] = omake_rule omake_build_type omake_build_tee omake_build_util omake_builtin_type omake_target omake_builtin omake_build MakeOCamlLibrary(build, $(FILES)) clean: $(CLEAN) # # Generate a Makefile # MakeOCamlDepend($(FILES), magic.cma) MakeMakefile() omake-0.10.3/src/build/omake_build_tee.ml0000644000175000017500000001024013177364665016662 0ustar gerdgerd (* * The empty tee. *) (* let tee_none = Omake_exec_util.tee_create false *) (* * Unlink all the tee files. * * XXX: HACK: It is hard to convince Windows not to hold on to these files, * so we keep track of those that we have failed to unlink and delete them * later on. *) let failed_unlink = ref Lm_string_set.StringSet.empty let try_unlink table name = try Unix.unlink name; table with Unix.Unix_error(Unix.ENOENT, _, _) -> table | Unix.Unix_error _ -> Lm_string_set.StringSet.add table name let unlink_file name = let table = Lm_string_set.StringSet.add (!failed_unlink) name in failed_unlink := Lm_string_set.StringSet.fold try_unlink Lm_string_set.StringSet.empty table (* * Print all tees. *) let eprint_file_exn copy name = let buf = Bytes.create 1024 in let fd = Unix.openfile name [O_RDONLY] 0o000 in begin try copy buf fd with Unix.Unix_error _ -> Unix.close fd; Format.eprintf "*** omake: error reading file %s@." name | exn -> Unix.close fd; raise exn end; Unix.close fd let rec copy_stderr buf fd = let amount = Unix.read fd buf 0 (Bytes.length buf) in if amount > 0 then begin let _ = Unix.write Unix.stderr buf 0 amount in copy_stderr buf fd end let eprint_file = eprint_file_exn copy_stderr (* Will omit the trailing newline. Will return a bool indicating whether the newline was omited *) let rec format_string_with_nl buf s = if String.contains s '\n' then begin let i = String.index s '\n' in let len = String.length s - 1 in Lm_printf.pp_print_string buf (String.sub s 0 i); if len > i then begin Format.pp_force_newline buf (); format_string_with_nl buf (String.sub s (i + 1) (len - i)) end else (* Omit the trailing newline *) true end else begin Lm_printf.pp_print_string buf s; false end let rec copy_with_nl_exn out pending_nl buf fd = let amount = Unix.read fd buf 0 (Bytes.length buf) in if amount > 0 then begin if pending_nl then Format.pp_force_newline out (); let pending_nl = format_string_with_nl out (Bytes.sub_string buf 0 amount) in copy_with_nl_exn out pending_nl buf fd end let format_file_with_nl buf name = eprint_file_exn (copy_with_nl_exn buf true) name (* * Close tee channels. * For commands that are successful, repeat the diversion. *) let env_close_success_tee _ (command : Omake_build_type.command) = match command with { command_venv = venv; command_tee = tee; _ } -> match Omake_exec_util.tee_file tee with Some name -> Omake_exec_util.tee_close tee; if Omake_options.opt_output (Omake_env.venv_options venv) OutputPostponeSuccess then begin Omake_exec_print.progress_flush(); eprint_file name end; unlink_file name; command.command_tee <- Omake_exec_util.tee_none | None -> () (* * For failed commands, repeat the diversion immediately * if the DivertRepeat flag is specified. * * Don't remove the diversion if we are going to print it again * at the end of the run. *) let env_close_failed_tee _ (command : Omake_build_type.command) = match command with { command_venv = venv; command_tee = tee; _ } -> match Omake_exec_util.tee_file tee with Some name -> let options = Omake_env.venv_options venv in Omake_exec_util.tee_close tee; if Omake_options.opt_output options OutputPostponeError then begin Omake_exec_print.progress_flush(); eprint_file name; if not (Omake_options.opt_output options OutputRepeatErrors) then begin unlink_file name; command.command_tee <- Omake_exec_util.tee_none; end; end | None -> () (* * Print a diversion. *) let format_tee_with_nl buf (command : Omake_build_type.command) = match Omake_exec_util.tee_file command.command_tee with Some name -> format_file_with_nl buf name | None -> () (* * Unlink the file. *) let unlink_tee (command : Omake_build_type.command) = match Omake_exec_util.tee_file command.command_tee with | Some name -> unlink_file name; command.command_tee <- Omake_exec_util.tee_none | None -> () omake-0.10.3/src/build/omake_rule.ml0000644000175000017500000015043713177364665015712 0ustar gerdgerd(* Rule evaluation. *) include Omake_pos.Make (struct let name = "Omake_rule" end);; type 'a result = | Success of 'a | Exception of exn (* * Debugging. *) let debug_active_rules = Lm_debug.create_debug (**) { debug_name = "active-rules"; debug_description = "Display debugging information for computed rules"; debug_value = false } (* * A data structure to keep sequences of command_info. * We can append a command to the current info, or * add another entirely new info. *) module type CommandSig = sig type t type resume (* Create a buffer *) val create : Omake_env.t -> Omake_node.Node.t -> Omake_value_type.t -> Omake_node.NodeSet.t -> Omake_node.NodeSet.t -> Omake_node.NodeSet.t -> Omake_node.NodeSet.t -> t (* Projections *) val target : t -> Omake_node.Node.t * Omake_value_type.t (* Adding to the buffer *) val add_command : t -> Omake_value_type.command -> t val add_locks : t -> Omake_node.NodeSet.t -> t val add_effects : t -> Omake_node.NodeSet.t -> t val add_scanners : t -> Omake_node.NodeSet.t -> t val add_deps : t -> Omake_node.NodeSet.t -> t (* Block operations *) val enter : t -> Omake_env.t -> Omake_node.Node.t list -> Omake_value_type.t list -> resume * t val resume : t -> resume -> t (* Get the final info *) val contents : t -> Omake_node.NodeSet.t * Omake_node.NodeSet.t * Omake_node.NodeSet.t * Omake_node.NodeSet.t * Omake_env.command_info list end module Command : CommandSig = struct (* * The command buffer. *) type t = { buf_target : Omake_node.Node.t; buf_core : Omake_value_type.t; buf_locks : Omake_node.NodeSet.t; buf_effects : Omake_node.NodeSet.t; buf_deps : Omake_node.NodeSet.t; buf_scanners : Omake_node.NodeSet.t; (* The state that is being collected *) buf_env : Omake_env.t; buf_sources : Omake_node.Node.t list; buf_values : Omake_value_type.t list; buf_commands : Omake_value_type.command list; (* The buffers that have already been collected *) buf_info : Omake_env.command_info list } type resume = Omake_env.t * Omake_node.Node.t list * Omake_value_type.t list (* * Create a new command buffer. *) let create venv target core locks effects deps scanners = { buf_target = target; buf_core = core; buf_locks = locks; buf_effects = effects; buf_deps = deps; buf_scanners = scanners; buf_env = venv; buf_sources = []; buf_values = []; buf_commands = []; buf_info = [] } (* * Projections. *) let target buf = let { buf_target = target; buf_core = core; _ } = buf in target, core (* * Add a command to the buffer. *) let add_command buf command = { buf with buf_commands = command :: buf.buf_commands } let add_locks buf locks = { buf with buf_locks = Omake_node.NodeSet.union buf.buf_locks locks } let add_effects buf effects = { buf with buf_effects = Omake_node.NodeSet.union buf.buf_effects effects } let add_deps buf deps = { buf with buf_deps = Omake_node.NodeSet.union buf.buf_deps deps } let add_scanners buf scanners = { buf with buf_scanners = Omake_node.NodeSet.union buf.buf_scanners scanners } (* * Start a new environment. * Return a state that can be used to resume the current environment. *) let enter buf venv sources values = let { buf_env = venv'; buf_sources = sources'; buf_values = values'; buf_commands = commands'; buf_info = info'; _ } = buf in let info = if commands' = [] && values' = [] then info' else let info = { Omake_env.command_env = venv'; command_sources = sources'; command_values = values'; command_body = List.rev commands' } in info :: info' in let buf = { buf with buf_env = venv; buf_sources = sources; buf_values = values; buf_commands = []; buf_info = info } in let resume = venv', sources', values' in resume, buf let resume buf (venv, sources, values) = snd (enter buf venv sources values) (* * Get the contents. *) let contents buf = let { buf_env = venv; buf_values = values; buf_sources = sources; buf_locks = locks; buf_effects = effects; buf_scanners = scanners; buf_deps = deps; buf_commands = commands; buf_info = info; _ } = buf in let info = if commands = [] && values = [] then info else let info' = {Omake_env.command_env = venv; command_sources = sources; command_values = values; command_body = List.rev commands } in info' :: info in let info = List.rev info in locks, effects, deps, scanners, info end (* * Find a rule in a list. *) let find_rule venv pos loc target names = if not (List.exists (Omake_node.Node.equal target) names) then raise (Omake_value_type.OmakeException (loc_exp_pos loc, StringNodeError ("computed rule does not match target", target))); Omake_env.venv_explicit_find venv pos target (* * Check if there are any computed commands. *) let commands_are_computed commands = List.exists (fun {Omake_env. command_body = body ; _} -> List.exists (fun (command : Omake_value_type.command) -> match command with | CommandSection _ -> true | CommandValue _ -> false) body) commands (* * Expand a single command. *) let rec expand_command venv pos loc buf (command : Omake_value_type.command) = let pos = string_pos "expand_command" pos in match command with | CommandValue _ -> Command.add_command buf command | CommandSection (arg, fv, el) -> if Lm_debug.debug debug_active_rules then Format.eprintf "@[section %a@ %a@]@." Omake_value_print.pp_print_value arg Omake_ir_print.pp_print_exp_list el; (* The section should be either a rule or eval case *) match Lm_string_util.trim (Omake_eval.string_of_value venv pos arg) with "" -> expand_eval_section venv pos loc buf "eval" fv el | "eval" as s -> expand_eval_section venv pos loc buf s fv el | "rule" -> expand_rule_section venv pos loc buf el | s -> raise (Omake_value_type.OmakeException (loc_exp_pos loc, StringStringError ("invalid section argument, valid arguments are rule, eval", s))) and expand_commands venv pos loc buf commands = match commands with command :: commands -> let buf = expand_command venv pos loc buf command in expand_commands venv pos loc buf commands | [] -> buf (* * This section computes a new rule for the target. *) and expand_rule_section venv pos loc buf e = let pos = string_pos "expand_rule_section" pos in let target, core = Command.target buf in let venv = Omake_env.venv_explicit_target venv target in let venv = Omake_env.venv_add_wild_match venv core in let _, v = Omake_eval.eval_sequence_exp venv pos e in if Lm_debug.debug debug_active_rules then Format.eprintf "@[%a@ @[*** omake: rule body returned@ @[%a@]@]@]@." (**) Lm_location.pp_print_location loc Omake_value_print.pp_print_value v; match v with ValRules erules -> let erule = find_rule venv pos loc target erules in let {Omake_env. rule_locks = locks; rule_effects = effects; rule_sources = deps; rule_scanners = scanners; rule_commands = commands; _ } = erule in let buf = Command.add_locks buf locks in let buf = Command.add_effects buf effects in let buf = Command.add_deps buf deps in let buf = Command.add_scanners buf scanners in expand_command_info_list pos loc buf commands | _ -> Format.eprintf "@[%a@ *** omake: section rule: did not compute a rule@]@." (**) Lm_location.pp_print_location loc; buf (* * This section is to be evaluated when the rule is run. *) and expand_eval_section _ pos _ buf s fv e = let _pos = string_pos "expand_eval_section" pos in Command.add_command buf (CommandSection (ValString s, fv, e)) (* * Expand a buf_info list. *) and expand_command_info pos loc buf command = match command with {Omake_env. command_env = venv; command_sources = sources; command_values = values; command_body = commands } -> let pos = string_pos "expand_buf_info" pos in let resume, buf = Command.enter buf venv sources values in let buf = expand_commands venv pos loc buf commands in Command.resume buf resume and expand_command_info_list pos loc buf commands = let pos = string_pos "expand_buf_info_list" pos in List.fold_left (expand_command_info pos loc) buf commands (* * Expand a rule, so that the commands are a command list. *) let expand_rule erule = match erule with {Omake_env. rule_loc = loc; rule_env = venv; rule_target = target; rule_locks = locks; rule_effects = effects; rule_match = core; rule_sources = deps; rule_scanners = scanners; rule_commands = commands; _ } -> if commands_are_computed commands then let core : Omake_value_type.t = match core with | Some s -> ValData s | None -> ValNode target in let pos = string_pos "expand_rule" (loc_exp_pos loc) in let buf = Command.create venv target core locks effects deps scanners in let buf = expand_command_info_list pos loc buf commands in let locks, effects, deps, scanners, commands = Command.contents buf in if Lm_debug.debug debug_active_rules then Format.eprintf "@[expand_rule: %a@ @[locks =%a@]@ @[effects =%a@]@ @[deps = %a@]@ @[scanners = %a@]@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set locks Omake_node.pp_print_node_set effects Omake_node.pp_print_node_set deps Omake_node.pp_print_node_set scanners; { erule with rule_locks = locks; rule_effects = effects; rule_sources = deps; rule_scanners = scanners; rule_commands = commands } else begin if Lm_debug.debug debug_active_rules then Format.eprintf "@[%a@ @[*** omake: static rule@ @[%a@]@]@]@." (**) Lm_location.pp_print_location loc Omake_env.pp_print_rule erule; erule end (************************************************************************ * Shell utilities. *) (* * Get the info for the command. *) let eval_shell_info command = match command with { Omake_command_type.command_flags = flags; command_dir = dir; command_target = target; _ } -> flags, dir, target (* * Kill a process. *) let eval_shell_kill venv pos (pid : Omake_env.pid) = match pid with | ExternalPid pid -> Unix.kill pid Sys.sigterm | InternalPid pid -> Omake_shell_job.kill venv pos pid SigTerm | ResultPid _ -> () (* * Wait for a process to exit. *) let eval_shell_wait venv pos pid = let pos = string_pos "eval_shell_wait" pos in let _, status, value = Omake_shell_job.waitpid venv pos pid in status, value (************************************************************************ * Globbing. *) let glob_options_of_string options s = let len = String.length s in let rec search options i = if i = len then List.rev options else let options : Lm_glob.glob_option list = match s.[i] with | 'b' -> GlobNoBraces :: options | 'e' -> GlobNoEscape :: options | 'c' | 'n' -> GlobNoCheck :: options | 'i' -> GlobIgnoreCheck :: options | 'A' | '.' -> GlobDot :: options | 'F' -> GlobOnlyFiles :: options | 'D' -> GlobOnlyDirs :: options | 'C' -> GlobCVSIgnore :: options | 'P' -> GlobProperSubdirs :: options | _ -> options in search options (succ i) in search options 0 (* * Glob an argument into directories and files. *) let glob_arg venv _ _ options arg = let cwd = Omake_env.venv_dir venv in let dirs, files = Lm_glob.glob options (Omake_node.Dir.fullname cwd) [Omake_command_type.glob_string_of_arg options arg] in let dirs = List.sort String.compare dirs in let files = List.sort String.compare files in let dirs = List.map (fun dir -> Omake_node.Dir.chdir cwd dir) dirs in let files = List.map (fun file -> Omake_env.venv_intern_cd venv PhonyProhibited cwd file) files in dirs, files (* * This is similar to the above, but we interleave the directories * with the files when sorting. *) type glob_result = GDir of string | GFile of string let glob_result_compare r1 r2 = let s1 = match r1 with GDir s | GFile s -> s in let s2 = match r2 with GDir s | GFile s -> s in -(String.compare s1 s2) let glob_rev_arg venv _ _ options arg argv = let cwd = Omake_env.venv_dir venv in let dirs, files = Lm_glob.glob options (Omake_node.Dir.fullname cwd) [Omake_command_type.glob_string_of_arg options arg] in let args = List.fold_left (fun args s -> GFile s :: args) [] files in let args = List.fold_left (fun args s -> GDir s :: args) args dirs in let args = List.sort glob_result_compare args in List.fold_left (fun argv arg -> let v = match arg with | GDir s -> Omake_value_type.ValDir (Omake_node.Dir.chdir cwd s) | GFile s -> ValNode (Omake_env.venv_intern_cd venv PhonyProhibited cwd s) in v :: argv) argv args (* * Glob the executable. * We do the standard thing, and allow glob expansions to multiple filenames. * In this case, the actual command is a bit ambiguous, so users should be * careful when they do it. *) let glob_arg_exe venv pos loc options (arg : Omake_command_type.arg) : (Omake_shell_type.simple_exe * Omake_node.Node.t list) = if Omake_command_type.is_glob_arg options arg then match glob_arg venv pos loc options arg with [], exe :: args -> ExeNode exe, args | [], [] -> raise (Omake_value_type.OmakeException (pos, StringError "null glob expansion")) | dir :: _, _ -> raise (Omake_value_type.OmakeException (pos, StringValueError ("is a directory", ValDir dir))) else if Omake_command_type.is_quoted_arg arg then ExeQuote (Omake_command_type.simple_string_of_arg arg), [] else Omake_shell_lex.parse_command_string (Omake_command_type.simple_string_of_arg arg), [] let glob_exe venv pos loc options (exe : Omake_command_type.arg Omake_shell_type.cmd_exe) : (Omake_shell_type.simple_exe * Omake_node.Node.t list) = match exe with CmdNode node -> ExeNode node, [] | CmdArg arg -> glob_arg_exe venv pos loc options arg (* * Glob expand the glob arguments. *) let glob_value_argv venv pos loc options argv = List.fold_left (fun argv v -> if Omake_value.is_glob_value options v then let arg = Omake_eval.arg_of_values venv pos [v] in glob_rev_arg venv pos loc options arg argv else v :: argv) [] (List.rev argv) (* * Glob the command line. *) let glob_command_line venv _ _ options argv = let cwd = Omake_env.venv_dir venv in let dir = Omake_node.Dir.fullname cwd in let argv = List.map (Omake_command_type.glob_string_of_arg options) argv in Lm_glob.glob_argv options dir argv (* * Glob an input or output file. *) let glob_channel venv pos loc options name = match name with | Omake_shell_type.RedirectNone | RedirectNode _ as file -> file | RedirectArg name -> match glob_arg venv pos loc options name with [], [node] -> RedirectNode node | dir :: _, _ -> raise (Omake_value_type.OmakeException (pos, StringValueError ("is a directory", ValDir dir))) | [], _ :: _ :: _ -> raise (Omake_value_type.OmakeException (pos, StringStringError ("ambiguous redirect", Omake_command_type.simple_string_of_arg name))) | [], [] -> raise (Omake_value_type.OmakeException (pos, StringStringError ("null redirect", Omake_command_type.simple_string_of_arg name))) (* * Convert the environment strings. *) let string_of_env env = List.map (fun (v, arg) -> v, Omake_command_type.simple_string_of_arg arg) env (************************************************************************ * Alias expansion. *) let find_alias_exn shell_obj venv pos loc exe = (* If this is an internal command, create the PipeApply *) let name = Lm_symbol.add exe in let v = Omake_env.venv_find_field_internal_exn shell_obj name in let _, f = Omake_eval.eval_fun venv pos v in (* Found the function, no exceptions now *) let f venv_orig stdin stdout stderr env argv = if !Omake_eval.debug_eval || !Omake_shell_type.debug_shell then Format.eprintf "Running %s, stdin=%i, stdout=%i, stderr=%i@." exe (Obj.magic stdin) (Obj.magic stdout) (Obj.magic stderr); let venv = Omake_env.venv_fork venv_orig in let venv = List.fold_left (fun venv (v, s) -> Omake_env.venv_setenv venv v s) venv env in let stdin_chan = Lm_channel.create "" Lm_channel.PipeChannel Lm_channel.InChannel false (Some stdin) in let stdout_chan = Lm_channel.create "" Lm_channel.PipeChannel Lm_channel.OutChannel false (Some stdout) in let stderr_chan = Lm_channel.create "" Lm_channel.PipeChannel Lm_channel.OutChannel false (Some stderr) in let stdin = Omake_env.venv_add_channel venv stdin_chan in let stdout = Omake_env.venv_add_channel venv stdout_chan in let stderr = Omake_env.venv_add_channel venv stderr_chan in let venv = Omake_env.venv_add_var venv Omake_var.stdin_var (ValChannel (InChannel, stdin)) in let venv = Omake_env.venv_add_var venv Omake_var.stdout_var (ValChannel (OutChannel, stdout)) in let venv = Omake_env.venv_add_var venv Omake_var.stderr_var (ValChannel (OutChannel, stderr)) in let v : Omake_value_type.t = ValArray argv in let () = if !Omake_eval.debug_eval then Format.eprintf "normalize_apply: evaluating internal function@." in let code, venv, value, reraise = try let venv, v = f venv pos loc [v] [] in let code = match v with | ValOther (ValExitCode code) -> code | _ -> 0 in code, venv, v, None with | Omake_value_type.ExitException (_, code) | Omake_value_type.ExitParentException (_, code) as exn -> code, venv, ValNone, Some exn | Omake_value_type.OmakeException _ | Omake_value_type.UncaughtException _ as exn -> Format.eprintf "%a@." Omake_exn_print.pp_print_exn exn; Omake_state.exn_error_code, venv, ValNone, None | Unix.Unix_error _ | Sys_error _ | Not_found | Failure _ as exn -> Format.eprintf "%a@." Omake_exn_print.pp_print_exn (Omake_value_type.UncaughtException (pos, exn)); Omake_state.exn_error_code, venv, ValNone, None in (* * XXX: JYH: we should probably consider combining the unfork * with venv_unexport. This is the only place where we actually * need the unexport. *) let venv = Omake_env.venv_unfork venv venv_orig in if !Omake_eval.debug_eval then Format.eprintf "normalize_apply: internal function is done: %d, %a@." code Omake_value_print.pp_print_value value; Omake_env.venv_close_channel venv pos stdin; Omake_env.venv_close_channel venv pos stdout; Omake_env.venv_close_channel venv pos stderr; match reraise with Some exn -> raise exn | None -> code, venv, value in name, f let find_alias obj venv pos loc exe = try Some (find_alias_exn obj venv pos loc exe) with Not_found -> None let find_alias_of_env venv pos = try let obj = Omake_env.venv_find_var_exn venv Omake_var.shell_object_var in match Omake_eval.eval_single_value venv pos obj with ValObject obj -> find_alias obj | _ -> raise Not_found with Not_found -> (fun _venv _pos _loc _exe -> None) (************************************************************************ * Rule evaluation. *) (* * Get the target string if there is a single one. *) let target_of_value venv pos (v : Omake_value_type.t) = match v with | ValNode node -> Omake_value_type.TargetNode node | _ -> TargetString (Omake_eval.string_of_value venv pos v) let targets_of_value venv pos v = List.map (target_of_value venv pos) (Omake_eval.values_of_value venv pos v) (* let pp_print_target buf (target : Omake_value_type.target) = *) (* match target with *) (* | TargetNode node -> *) (* Format.fprintf buf "TargetNode %a" Omake_node.pp_print_node node *) (* | TargetString s -> *) (* Format.fprintf buf "TargetString %s" s *) (* let pp_print_targets buf targets = *) (* List.iter (fun target -> Format.fprintf buf " %a" pp_print_target target) targets *) (* * From Omake_cache. *) let include_fun = Omake_cache.include_fun (* * Collect the different kinds of sources. *) let add_sources sources kind sources' = List.fold_left (fun sources source -> (kind, source) :: sources) sources sources' let sources_of_options venv pos loc sources options = let options = Omake_value.map_of_value venv pos options in let effects, sources, scanners, values = Omake_env.venv_map_fold (fun (effects, sources, scanners, values) optname optval -> let s = Omake_eval.string_of_value venv pos optname in let v = Lm_symbol.add s in if Lm_symbol.eq v Omake_symbol.normal_sym then let files = targets_of_value venv pos optval in effects, add_sources sources Omake_node_sig.NodeNormal files, scanners, values else if Lm_symbol.eq v Omake_symbol.optional_sym then let files = targets_of_value venv pos optval in effects, add_sources sources NodeOptional files, scanners, values else if Lm_symbol.eq v Omake_symbol.exists_sym then let files = targets_of_value venv pos optval in effects, add_sources sources NodeExists files, scanners, values else if Lm_symbol.eq v Omake_symbol.squash_sym then let files = targets_of_value venv pos optval in effects, add_sources sources NodeSquashed files, scanners, values else if Lm_symbol.eq v Omake_symbol.scanner_sym then let files = targets_of_value venv pos optval in effects, sources, add_sources scanners Omake_node_sig.NodeScanner files, values else if Lm_symbol.eq v Omake_symbol.effects_sym then let files = targets_of_value venv pos optval in add_sources effects Omake_node_sig.NodeNormal files, sources, scanners, values else if Lm_symbol.eq v Omake_symbol.values_sym then effects, sources, scanners, optval :: values else raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("unknown rule option", v)))) (**) ([], sources, [], []) options in List.rev effects, List.rev sources, List.rev scanners, List.rev values (* * Get the commands. *) let lazy_command venv pos (command : Omake_ir.exp) : Omake_value_type.command = match command with | SectionExp (_, s, el, _) -> let fv = Omake_ir_free_vars.free_vars_exp_list el in CommandSection (Omake_eval.eval_string_exp venv pos s, fv, el) | ShellExp (loc, s) -> CommandValue (loc, Omake_env.venv_get_env venv, s) | _ -> let fv = Omake_ir_free_vars.free_vars_exp command in CommandSection (ValData "eval", fv, [command]) let lazy_commands venv pos commands = match Omake_eval.eval_value venv pos commands with | ValBody (_, [], [], el, export) -> List.map (lazy_command venv pos) el, export | _ -> raise (Omake_value_type.OmakeFatalErr (pos, Omake_value_type.StringValueError ("unknown rule commands", commands))) let exp_list_of_commands venv pos commands = match Omake_eval.eval_value venv pos commands with | ValBody (_, [], [], el, _) -> el | _ -> raise (Omake_value_type.OmakeFatalErr (pos, Omake_value_type.StringValueError ("unknown rule commands", commands))) (* * Evaluate a .STATIC rule. *) let eval_memo_rule_exp venv pos loc multiple is_static key vars target source options body = let pos = string_pos "eval_memo_rule_exp" pos in (* First, evaluate the parts *) let sources = targets_of_value venv pos source in let sources = add_sources [] Omake_node_sig.NodeNormal sources in let sources = (Omake_node_sig.NodeNormal, Omake_value_type.TargetNode target) :: sources in let effects, sources, scanners, values = sources_of_options venv pos loc sources options in let el = exp_list_of_commands venv pos body in let e : Omake_ir.exp = SequenceExp (loc, el) in (* Reject some special flags *) let () = if effects <> [] || scanners <> [] then raise (Omake_value_type.OmakeException (loc_exp_pos loc, SyntaxError ".STATIC rules cannot have effects or scanners")) in (* Add the rule *) let venv = Omake_env.venv_add_memo_rule venv pos loc multiple is_static key vars sources values e in venv (* * Evaluate a rule. * * There are two types of rules. Implicit rules are 2-place rules that * have a % in the target name, or 3-place rules. Explicit rules are 2-place rules * that do not have a %. *) let rec eval_rule_exp venv pos loc multiple target pattern source options body = let pos = string_pos "eval_rule_exp" pos in (* First, evaluate the parts *) let targets = targets_of_value venv pos target in let patterns = targets_of_value venv pos pattern in let sources = targets_of_value venv pos source in let sources = add_sources [] Omake_node_sig.NodeNormal sources in let effects, sources, scanners, values = sources_of_options venv pos loc sources options in let commands, export = lazy_commands venv pos body in let commands_are_nontrivial = commands <> [] in (* Process special rules *) match targets with | [TargetString ".SUBDIRS"] -> if effects <> [] || patterns <> [] || scanners <> [] || values <> [] then raise (Omake_value_type.OmakeException (loc_exp_pos loc, SyntaxError ".SUBDIRS rule cannot have patterns, effects, scanners, or values")); let venv = eval_subdirs_rule venv loc sources (exp_list_of_commands venv pos body) export in venv, Omake_value_type.ValNone | [TargetString ".PHONY"] -> let targets, sources = if patterns = [] then List.map snd sources, [] else patterns, sources in let multiple = if multiple then Omake_value_type.RuleMultiple else Omake_value_type.RuleSingle in let venv = Omake_env.venv_add_phony venv loc targets in if effects <> [] || sources <> [] || scanners <> [] || values <> [] || commands_are_nontrivial then let venv, rules = Omake_env.venv_add_rule venv pos loc multiple targets [TargetString "%"] effects sources scanners values commands in venv, ValRules rules else venv, ValNone | [TargetString ".SCANNER"] -> let targets, sources = if patterns = [] then List.map snd sources, [] else patterns, sources in let multiple = if multiple then Omake_value_type.RuleScannerMultiple else Omake_value_type.RuleScannerSingle in let venv, rules = Omake_env.venv_add_rule venv pos loc multiple targets [] effects sources scanners values commands in venv, ValRules rules | [TargetString ".INCLUDE"] -> if effects <> [] || scanners <> [] then raise (Omake_value_type.OmakeException (loc_exp_pos loc, SyntaxError ".INCLUDE cannot have effects or scanners")); let targets, sources = if patterns = [] then List.map snd sources, [] else patterns, sources in let venv = eval_include_rule venv pos loc targets sources values commands in venv, ValNone | [TargetString ".ORDER"] -> if commands_are_nontrivial then raise (Omake_value_type.OmakeException (loc_exp_pos loc, SyntaxError ".ORDER rules cannot have build commands")); if effects <> [] || patterns <> [] || scanners <> [] || values <> [] then raise (Omake_value_type.OmakeException (loc_exp_pos loc, SyntaxError ".ORDER rules cannot have patterns, effects, scanners, or values")); let sources = List.map snd sources in let venv = Omake_env.venv_add_phony venv loc sources in let venv = Omake_env.venv_add_orders venv loc sources in venv, ValNone (* .ORDER rules are handled specially *) | [TargetString name] when Omake_env.venv_is_order venv name -> let name = Lm_symbol.add name in if commands_are_nontrivial then raise (Omake_value_type.OmakeException (loc_exp_pos loc, SyntaxError ".ORDER rule cannot have build commands")); if effects <> [] || scanners <> [] || values <> [] then raise (Omake_value_type.OmakeException (loc_exp_pos loc, SyntaxError ".ORDER rule cannot have effects, scanners, or values")); let venv = eval_ordering_rule venv pos loc name patterns sources in venv, ValNone | _ -> (* Normal rule *) let multiple = if multiple then Omake_value_type.RuleMultiple else Omake_value_type.RuleSingle in let venv, rules = Omake_env.venv_add_rule venv pos loc multiple targets patterns effects sources scanners values commands in venv, ValRules rules (* * Read the OMakefiles in the subdirectories too. *) and eval_subdirs_rule venv loc sources commands export = List.fold_left (fun venv dir -> eval_subdir venv loc dir commands export) venv sources (* * Compile an OMakefile. *) and eval_subdir venv loc (kind, dir) commands export = let pos = string_pos "eval_subdir" (loc_exp_pos loc) in let cache = Omake_env.venv_cache venv in let dir = Omake_env.venv_intern_dir venv (Omake_env.string_of_target venv dir) in let () = if kind <> Omake_node_sig.NodeNormal then Format.eprintf "*** omake: .SUBDIRS kind %a not implemented@." Omake_node.pp_print_node_kind kind; (* Check that the directory exists *) if not (Omake_cache.exists_dir cache dir) then let create_flag = try Omake_eval.bool_of_value venv pos (Omake_env.venv_find_var_exn venv Omake_var.create_subdirs_var) with Not_found -> false in if create_flag then let name = Omake_node.Dir.fullname dir in try Lm_filename_util.mkdirhier name 0o777 with Unix.Unix_error _ -> raise (Omake_value_type.OmakeException (pos, StringDirError ("can't create directory", dir))) else raise (Omake_value_type.OmakeException (pos, StringDirError ("directory does not exist", dir))) in let cwd = Omake_env.venv_dir venv in let venv_body = Omake_env.venv_chdir_dir venv loc dir in let node = Omake_env.venv_intern venv_body PhonyProhibited Omake_state.makefile_name in let venv_body, _ = (* * Ignore the file if the commands are listed explicity. * The OMakefile can always be included explicitly. *) if commands <> [] then Omake_eval.eval_sequence_exp venv_body pos commands (* Otherwise, use the file if it exists *) else if Omake_cache.exists cache node then let venv_body = Omake_env.venv_add_file venv_body node in let name = Omake_node.Node.fullname node in let loc = Lm_location.bogus_loc name in let venv_body = Omake_eval.include_file venv_body IncludeAll pos loc node in venv_body, ValNone (* Otherwise, check if an empty file is acceptable *) else let allow_empty_subdirs = try Omake_eval.bool_of_value venv_body pos (Omake_env.venv_find_var_exn venv_body Omake_var.allow_empty_subdirs_var) with Not_found -> false in if not allow_empty_subdirs then raise (Omake_value_type.OmakeException (pos, StringNodeError ("file does not exist", node))); venv_body, ValNone in (* * Save the resulting environment as the default to use * for targets in this directory. Also change back to the * current directory. *) let venv = Omake_env.venv_add_dir venv_body; Omake_env.add_exports venv venv_body pos export in let venv = Omake_env.venv_chdir_tmp venv cwd in if Lm_debug.debug Omake_eval.print_rules then Format.eprintf "@[Rules:%a@]@." Omake_env.pp_print_explicit_rules venv; venv (* * Include all the sources. *) and eval_include_rule venv pos loc sources deps values commands = let pos = string_pos "eval_include_rule" pos in (* Targets and dependencies *) let target = match sources with [source] -> Omake_env.venv_intern_target venv PhonyProhibited source | _ -> raise (Omake_value_type.OmakeException (pos, StringError ".INCLUDE must have a single source")) in let venv = Omake_env.venv_add_file venv target in let deps = List.map (fun (_, dep) -> Omake_env.venv_intern_target venv PhonyOK dep) deps in (* Convert the command list *) let commands = { Omake_env.command_env = venv; Omake_env.command_sources = deps; Omake_env.command_values = values; Omake_env.command_body = commands } in let commands = eval_commands venv loc target Omake_node.NodeSet.empty [commands] in let commands_digest = Omake_command_digest.digest_of_commands pos commands in (* Ask the cache if this file is up-to-date *) let cache = Omake_env.venv_cache venv in let deps = List.fold_left Omake_node.NodeSet.add Omake_node.NodeSet.empty deps in let up_to_date = Omake_cache.up_to_date cache include_fun deps commands_digest in let () = (* Run the commands if there are deps, or if the file does not exist *) if commands <> [] && (not up_to_date || Omake_cache.stat cache target = None) then exec_commands venv pos loc commands; (* Check that it exists *) if Omake_cache.force_stat cache target = None then raise (Omake_value_type.OmakeException (pos, StringNodeError (".INCLUDE rule failed to build the target", target))); (* Tell the cache we did the update *) Omake_cache.add cache include_fun target (Omake_node.NodeSet.singleton target) deps commands_digest (MemoSuccess Omake_node.NodeTable.empty) in Omake_eval.include_file venv IncludePervasives pos loc target (* * Evaluate the commands NOW. *) and exec_commands venv pos loc commands = let stdout = Omake_value.channel_of_var venv pos loc Omake_var.stdout_var in let stderr = Omake_value.channel_of_var venv pos loc Omake_var.stderr_var in let stdout = Lm_channel.descr stdout in let stderr = Lm_channel.descr stderr in List.iter (fun command -> let pid = eval_shell_internal stdout stderr command in let status, _ = eval_shell_wait venv pos pid in let code = match status with | Unix.WEXITED i | Unix.WSIGNALED i | Unix.WSTOPPED i -> i in if code <> 0 then raise (Omake_value_type.OmakeException (pos, StringIntError ("command exited with code", code)))) commands (* * Evaluate the command lines. *) and eval_commands _ loc target sloppy_deps commands : Omake_env.arg_command_line list = let rec collect commands' commands = match commands with command :: commands -> let { Omake_env.command_env = venv; Omake_env.command_sources = sources; Omake_env.command_values = values; Omake_env.command_body = body } = command in let lines = eval_rule venv loc target sources sloppy_deps values body in let commands' = List.rev_append lines commands' in collect commands' commands | [] -> List.rev commands' in collect [] commands (* * Evaluate the rule lines. * Add these extra variables. * $@: the target file * $*: the target file, without suffix * $>: the target, without the directory part and without suffixes * $<: the first source * $+: all the sources * $^: the sources, in alphabetical order, with duplicates removed * $&: the scanner dependencies from the last run *) and eval_rule venv loc target sources sloppy_deps values commands = let pos = string_pos "eval_rule" (loc_exp_pos loc) in let target_name = Omake_env.venv_nodename venv target in let root = Lm_filename_util.root target_name in let root' = Lm_filename_util.strip_suffixes target_name in let venv = Omake_env.venv_add_var venv Omake_var.star_var (ValData root) in let venv = Omake_env.venv_add_var venv Omake_var.gt_var (ValData root') in let venv = Omake_env.venv_add_var venv Omake_var.at_var (ValNode target) in let source_all : Omake_value_type.t = ValArray (List.map (fun v -> Omake_value_type.ValNode v) sources) in let source_names = List.map (Omake_env.venv_nodename venv) sources in let source_set = List.fold_left Lm_string_set.LexStringSet.add Lm_string_set.LexStringSet.empty source_names in let source_set = Lm_string_set.LexStringSet.to_list source_set in let source_set = Omake_value_type.ValArray (List.map (fun s -> Omake_value_type.ValData s) source_set) in let source : Omake_value_type.t = match sources with | source :: _ -> ValNode source | [] -> ValNone in let venv = Omake_env.venv_add_var venv Omake_var.plus_var source_all in let venv = Omake_env.venv_add_var venv Omake_var.hat_var source_set in let venv = Omake_env.venv_add_var venv Omake_var.lt_var source in let sloppy_deps = List.map (fun v ->Omake_value_type. ValNode v) (Omake_node.NodeSet.to_list sloppy_deps) in let venv = Omake_env.venv_add_var venv Omake_var.amp_var (ValArray sloppy_deps) in let options = Lm_glob.create_options (glob_options_of_env venv pos) in let find_alias = find_alias_of_env venv pos in let command_line (commands, fv) command = match (command : Omake_value_type.command) with | CommandSection (_, fv', e) -> let commands = ([], Omake_command_type.CommandEval e) :: commands in let fv = Omake_ir_free_vars.free_vars_union fv fv' in commands, fv | CommandValue (loc, env, s) -> let v = Omake_value_type.ValStringExp (env, s) in let commands = try let flags, pipe = Omake_shell_lex.pipe_of_value venv find_alias options pos loc v in (flags, Omake_command_type.CommandPipe pipe) :: commands with Omake_value_type.OmakeException (_, NullCommand) -> commands in commands, fv in let commands, fv = List.fold_left command_line ([], Omake_ir_free_vars.free_vars_empty) commands in let commands = List.rev commands in let values = Omake_ir_util.VarInfoSet.fold (fun values v -> Omake_value_type.ValMaybeApply (loc, v) :: values) values (Omake_ir_free_vars.free_vars_set fv) in let values = List.fold_left (fun values v -> List.rev_append (Omake_eval.values_of_value venv pos v) values) [] values in let values = List.map (Omake_eval.eval_prim_value venv pos) values in let commands = if values = [] then commands else ([], CommandValues values) :: commands in let dir = Omake_env.venv_dir venv in Omake_command.parse_commands venv dir target loc commands (* * Add an ordering constraint. *) and eval_ordering_rule venv pos loc name patterns sources = let pos = string_pos "eval_ordering_rule" pos in let sources = List.map snd sources in List.fold_left (fun venv pattern -> Omake_env.venv_add_ordering_rule venv pos loc name pattern sources) venv patterns (************************************************************************ * Shell. *) (* * Get globbing options from the environment. *) and glob_options_of_env venv pos = let options = [] in let options = try let s = Omake_env.venv_find_var_exn venv Omake_var.glob_options_var in let s = Omake_eval.string_of_value venv pos s in glob_options_of_string options s with Not_found -> options in let options : Lm_glob.glob_option list = try let ignore = Omake_env.venv_find_var_exn venv Omake_var.glob_ignore_var in let ignore = Omake_eval.strings_of_value venv pos ignore in GlobIgnore ignore :: options with Not_found -> options in let options : Lm_glob.glob_option list = try let allow = Omake_env.venv_find_var_exn venv Omake_var.glob_allow_var in let allow = Omake_eval.strings_of_value venv pos allow in GlobAllow allow :: options with Not_found -> options in options and compile_glob_options venv pos = Lm_glob.create_options (glob_options_of_env venv pos) (* * Set the path environment variable. *) and eval_path venv pos = let pos = string_pos "eval_path" pos in try let path = Omake_env.venv_find_var_exn venv Omake_var.path_var in let options = Omake_env.venv_options venv in let venv' = if Omake_options.opt_absname options then venv else Omake_env.venv_with_options venv ( Omake_options.set_absname_opt options true) in let path = Omake_eval.strings_of_value venv' pos path in let path = String.concat Lm_filename_util.pathsep path in Omake_env.venv_setenv venv Omake_symbol.path_sym path with Not_found -> venv (* * Evaluate a shell expression. *) and eval_shell_exp venv pos loc e = let pos = string_pos "eval_shell_exp" pos in let venv = eval_path venv pos in let find_alias = find_alias_of_env venv pos in let options = compile_glob_options venv pos in let _, pipe = Omake_shell_lex.pipe_of_value venv find_alias options pos loc e in let pipe = normalize_pipe venv pos pipe in let stdin = Omake_value.channel_of_var venv pos loc Omake_var.stdin_var in let stdout = Omake_value.channel_of_var venv pos loc Omake_var.stdout_var in let stderr = Omake_value.channel_of_var venv pos loc Omake_var.stderr_var in let stdin = Lm_channel.descr stdin in let stdout = Lm_channel.descr stdout in let stderr = Lm_channel.descr stderr in let venv, result = Omake_shell_job.create_job venv pipe stdin stdout stderr in (* Get the exit code *) let code = match result with ValInt i | ValOther (ValExitCode i) -> i | _ -> 0 in (* Check exit code *) let exit_on_error = try Omake_eval.bool_of_value venv pos (Omake_env.venv_find_var_exn venv Omake_var.abort_on_command_error_var) with Not_found -> false in let () = if exit_on_error && code <> 0 then let print_error buf = Format.fprintf buf "@[command terminated with code %d:@ %a@]@." code Omake_env.pp_print_string_pipe pipe in raise (Omake_value_type.OmakeException (loc_pos loc pos, LazyError print_error)) in venv, result (* * Save the output in a file and return the string. *) and eval_shell_output venv pos loc e = let pos = string_pos "eval_shell_output" pos in let tmpname = Filename.temp_file "omake" ".shell" in let fd = Lm_unix_util.openfile tmpname [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC] 0o600 in let channel = Lm_channel.create tmpname Lm_channel.PipeChannel Lm_channel.OutChannel false (Some fd) in let channel = Omake_env.venv_add_channel venv channel in let venv = Omake_env.venv_add_var venv Omake_var.stdout_var (ValChannel (OutChannel, channel)) in let result = try let _ = eval_shell_exp venv pos loc e in let len = Unix.lseek fd 0 Unix.SEEK_END in let _ = Unix.lseek fd 0 Unix.SEEK_SET in let data = Bytes.create len in Lm_unix_util.really_read fd data 0 len; Success (Bytes.to_string data) with exn -> Exception exn in Omake_env.venv_close_channel venv pos channel; Unix.unlink tmpname; match result with Success result -> result | Exception exn -> raise exn (* * Construct a shell. *) and eval_shell venv pos : _ Omake_exec_type.shell = let pos = string_pos "eval_shell" pos in let venv = eval_path venv pos in { shell_eval = eval_shell_internal; shell_eval_is_nop = eval_shell_is_nop; shell_eval_is_cmd = eval_shell_is_cmd; shell_info = eval_shell_info; shell_kill = eval_shell_kill venv pos; shell_wait = eval_shell_wait venv pos; shell_error_value = ValNone; shell_print_exp = Omake_env.pp_print_arg_command_line; shell_print_exn = Omake_exn_print.pp_print_exn; shell_is_failure_exn = Omake_exn_print.is_shell_exn } and eval_shell_is_nop command = match command.command_inst with | CommandValues _ -> true | _ -> false and eval_shell_is_cmd command = match command.command_inst with | CommandPipe p -> eval_pipe_is_cmd p | _ -> false and eval_pipe_is_cmd p = match p with | PipeCommand _ -> true | PipeCond(_,_,p1,p2) -> eval_pipe_is_cmd p1 || eval_pipe_is_cmd p2 | PipeCompose(_,_,p1,p2) -> eval_pipe_is_cmd p1 || eval_pipe_is_cmd p2 | PipeGroup(_,g) -> eval_pipe_is_cmd g.group_pipe | PipeBackground(_,p1) -> eval_pipe_is_cmd p1 | _ -> false (* * Evaluate a shell command using the internal shell. *) and eval_shell_internal stdout stderr (command : Omake_env.arg_command_line) = match command with { Omake_command_type.command_loc = loc; command_venv = venv; command_inst = inst; _ } -> let pos = string_pos "eval_shell_internal" (loc_exp_pos loc) in match inst with CommandEval e -> eval_command venv stdout stderr pos loc e | CommandValues _ -> ResultPid (0, venv, ValNone) | CommandPipe pipe -> let pipe = normalize_pipe venv pos pipe in let pid = if !Omake_eval.debug_eval then Format.eprintf "eval_shell_internal: creating job@."; Omake_shell_job.create_process venv pipe Unix.stdin stdout stderr in if !Omake_eval.debug_eval then Format.eprintf "eval_shell_internal: created job@."; pid (* * Used to evaluate expressions. *) and eval_command venv stdout stderr pos loc e = let f stdin stdout stderr = if !Omake_eval.debug_eval || !Omake_shell_type.debug_shell then Format.eprintf "eval_command: evaluating internal function: stderr = %d@." (Lm_unix_util.int_of_fd stderr); let venv = Omake_env.venv_fork venv in let stdin = Lm_channel.create "" Lm_channel.PipeChannel Lm_channel.InChannel false (Some stdin) in let stdout = Lm_channel.create "" Lm_channel.PipeChannel Lm_channel.OutChannel false (Some stdout) in let stderr = Lm_channel.create "" Lm_channel.PipeChannel Lm_channel.OutChannel false (Some stderr) in let stdin = Omake_env.venv_add_channel venv stdin in let stdout = Omake_env.venv_add_channel venv stdout in let stderr = Omake_env.venv_add_channel venv stderr in let venv = Omake_env.venv_add_var venv Omake_var.stdin_var (ValChannel (InChannel, stdin)) in let venv = Omake_env.venv_add_var venv Omake_var.stdout_var (ValChannel (OutChannel, stdout)) in let venv = Omake_env.venv_add_var venv Omake_var.stderr_var (ValChannel (OutChannel, stderr)) in let code = try (match snd (Omake_eval.eval_sequence_exp venv pos e) with ValRules _ -> Format.eprintf "@[*** omake warning:@ %a@ Rule value discarded.@]@." (**) pp_print_pos (loc_pos loc pos) | _ -> ()); 0 with | Omake_value_type.ExitException (_, code) -> code | Omake_value_type.OmakeException _ | Omake_value_type.UncaughtException _ as exn -> Format.eprintf "%a@." Omake_exn_print.pp_print_exn exn; Omake_state.exn_error_code | Omake_value_type.ExitParentException _ | Unix.Unix_error _ | Sys_error _ | Not_found | Failure _ as exn -> Format.eprintf "%a@." Omake_exn_print.pp_print_exn (Omake_value_type.UncaughtException (pos, exn)); Omake_state.exn_error_code in if !Omake_eval.debug_eval then Format.eprintf "eval_command: internal function is done: %d@." code; Omake_env.venv_close_channel venv pos stdin; Omake_env.venv_close_channel venv pos stdout; Omake_env.venv_close_channel venv pos stderr; code in if !Omake_eval.debug_eval then Format.eprintf "eval_command: creating thread, stderr = %d@." (Lm_unix_util.int_of_fd stderr); Omake_shell_job.create_thread venv f Unix.stdin stdout stderr (* * Normalize the pipe, so the background is only outermost, * and translate commands to aliases. * * The directory must be an absolute name. *) and normalize_pipe venv pos pipe = let pos = string_pos "normalize_pipe" pos in let options = Lm_glob.create_options (glob_options_of_env venv pos) in normalize_pipe_options venv pos false options pipe and normalize_pipe_options venv pos squash options (pipe : Omake_env.arg_pipe) : Omake_env.string_pipe = match pipe with PipeApply (loc, apply) -> PipeApply (loc, normalize_apply venv pos loc options apply) | PipeCommand (loc, command) -> PipeCommand (loc, normalize_command venv pos loc options command) | PipeCond (loc, op, pipe1, pipe2) -> PipeCond (loc, op, (**) normalize_pipe_options venv pos true options pipe1, normalize_pipe_options venv pos true options pipe2) | PipeCompose (loc, divert_stderr, pipe1, pipe2) -> PipeCompose (loc, divert_stderr, (**) normalize_pipe_options venv pos true options pipe1, normalize_pipe_options venv pos true options pipe2) | PipeGroup (loc, group) -> normalize_group venv pos loc options group | PipeBackground (loc, pipe) -> let pipe = normalize_pipe_options venv pos true options pipe in if squash then pipe else PipeBackground (loc, pipe) (* * Normalize an alias. *) and normalize_apply venv pos loc options apply = match apply with {Omake_shell_type. apply_env = env; apply_args = argv; apply_stdin = stdin; apply_stdout = stdout; _ } -> { apply with apply_env = string_of_env env; apply_args = glob_value_argv venv pos loc options argv; apply_stdin = glob_channel venv pos loc options stdin; apply_stdout = glob_channel venv pos loc options stdout } (* * Normalize a command. * Glob-expand the arguments, and normalize the redirect names. *) and normalize_command venv pos loc options command = let pos = string_pos "normalize_command" pos in match command with { Omake_shell_type. cmd_env = env; cmd_exe = exe; cmd_argv = argv; cmd_stdin = stdin; cmd_stdout = stdout; _ } -> let exe, args = glob_exe venv pos loc options exe in let argv = glob_command_line venv pos loc options argv in let argv = match args with [] -> argv | _ -> List.fold_left (fun argv node -> Omake_env.venv_nodename venv node :: argv) argv (List.rev args) in { command with cmd_env = string_of_env env; cmd_exe = exe; cmd_argv = argv; cmd_stdin = glob_channel venv pos loc options stdin; cmd_stdout = glob_channel venv pos loc options stdout } (* * Normalize a group. * Normalize the redirect names. *) and normalize_group venv pos loc options group = let pos = string_pos "normalize_group" pos in match group with { group_stdin = stdin; group_stdout = stdout; group_pipe = pipe; _ } -> PipeGroup (loc, { group with group_stdin = glob_channel venv pos loc options stdin; group_stdout = glob_channel venv pos loc options stdout; group_pipe = normalize_pipe_options venv pos false options pipe }) omake-0.10.3/src/build/omake_build.ml0000644000175000017500000026077313177364665016047 0ustar gerdgerd module Pos = Omake_pos.Make (struct let name = "Omake_build" end);; exception BuildExit of int type prompt_state = { count : int; (* success count *) save : float; (* next .omakedb save time *) progress : float; (* next progress bar update time *) } let save_interval = ref Omake_magic.default_save_interval (* * XXX: Should this be an option as well? *) let prompt_interval = 0.5 (* * Maximum number of events that can be queued during * the .BUILD_* phases. *) let max_pending_events = 256 (* * Build debugging. *) let debug_rule = Lm_debug.create_debug (**) { debug_name = "rule"; debug_description = "Display debugging information for rule execution"; debug_value = false } let debug_build = Lm_debug.create_debug (**) { debug_name = "build"; debug_description = "Display debugging information during the build process"; debug_value = false } let debug_deps = Lm_debug.create_debug (**) { debug_name = "deps"; debug_description = "Display dependency information as it is read"; debug_value = false } let scanner_fun = Omake_cache.scanner_fun let rule_fun = Omake_cache.rule_fun let env_fun = Omake_cache.env_fun let env_target = Omake_cache.env_target (* * The argument to "Restart" is the reason for restarting. * The default reason is a change in one of the OMakefiles or included files. *) exception Restart of string option exception UnknownTarget of Omake_node.Node.t type default_scanner_mode = | IsEnabled | IsDisabled | IsWarning | IsError (** Special nodes. *) let build_begin = ".BUILD_BEGIN" let build_success = ".BUILD_SUCCESS" let build_failure = ".BUILD_FAILURE" let build_begin_target = Omake_node.Node.create_phony_global build_begin let build_success_target = Omake_node.Node.create_phony_global build_success let build_failure_target = Omake_node.Node.create_phony_global build_failure (* * Check if a command list contains value dependencies. *) let commands_have_value_dependencies commands = List.exists (fun (command : Omake_env.command_info) -> command.command_values <> []) commands let flatten_deps table = Omake_node.NodeTable.fold (fun deps1 _ deps2 -> Omake_node.NodeSet.union deps1 deps2) Omake_node.NodeSet.empty table (* * Get the scanner mode. *) let venv_find_scanner_mode venv pos = try let v = Omake_env.venv_find_var_exn venv Omake_var.scanner_mode_var in match Omake_eval.string_of_value venv pos v with | "enabled" -> IsEnabled | "disabled" -> IsDisabled | "warning" -> IsWarning | "error" -> IsError | s -> raise (Omake_value_type.OmakeException (pos, StringStringError ("bad scanner mode (should be enabled, disabled, error, or warning)", s))) with Not_found -> IsError let restartable_exn = function | Omake_value_type.OmakeException _ | Omake_value_type.UncaughtException _ | Omake_value_type.RaiseException _ -> true | _ -> false (* * JYH: the overhead of scanning directories every time * it changes is pretty high. We may want to think of * other ways of doing this. * * Intercept directory change events and pretend that every file * in the directory has changed. *) let process_changes is_node_relevant process_node venv cwd cache (event : Lm_notify.event) = let process_node name = let node = Omake_env.venv_intern_cd venv PhonyProhibited cwd name in let changed = is_node_relevant node && Omake_cache.stat_changed cache node in if !Lm_notify.debug_notify then Format.eprintf "Omake_build.process_changes: received %s event for node: %a@." (if changed then "relevant" else "ignored") Omake_node.pp_print_node node; if changed then process_node node; changed in match event with { notify_code = DirectoryChanged; notify_name = name } -> List.fold_left (fun changed name -> process_node name || changed) false (Lm_unix_util.list_directory name) | { notify_code = (Changed | Created); notify_name = name } -> process_node name | _ -> false (* * Find a command from a target. * May raise Not_found. *) let find_command (env : Omake_build_type.t) target = Omake_node.NodeTable.find env.env_commands target (* * Find the immediate parents of a node in the dependency DAG *) let find_parents (env : Omake_build_type.t) node = try let inverse = Omake_node.NodeTable.find env.env_inverse node in Omake_node.NodeTable.fold (fun nodes node _ -> Omake_node.NodeSet.add nodes node) Omake_node.NodeSet.empty inverse with Not_found -> Omake_node.NodeSet.empty (* * Compute all of the dependencies. *) let all_dependencies dependencies_of (env : Omake_build_type.t) nodes = let commands = env.env_commands in let rec find_deps found examined unexamined = if Omake_node.NodeSet.is_empty unexamined then found else let node = Omake_node.NodeSet.choose unexamined in let unexamined = Omake_node.NodeSet.remove unexamined node in if Omake_node.NodeSet.mem examined node then find_deps found examined unexamined else let examined = Omake_node.NodeSet.add examined node in let found, deps = try let command = Omake_node.NodeTable.find commands node in let deps = dependencies_of command in let found = Omake_node.NodeSet.add found node in found, deps with Not_found -> found, Omake_node.NodeSet.empty in let unexamined = Omake_node.NodeSet.union unexamined deps in find_deps found examined unexamined in find_deps Omake_node.NodeSet.empty Omake_node.NodeSet.empty nodes let all_build_dependencies = all_dependencies (fun command -> command.command_build_deps) let all_scanner_dependencies = all_dependencies (fun command -> command.command_scanner_deps) (* * Print the dependency information. *) let rec pp_print_dependencies_aux show_all env buf (command : Omake_build_type.command) = match command with { command_target = target; command_effects = effects; command_scanner_deps = scanner_deps; command_static_deps = static_deps; command_build_deps = build_deps; _} -> let inverse = find_parents env target in let options = Omake_env.venv_options env.env_venv in let total, build_deps, scanner_deps = if show_all && Omake_options.opt_all_dependencies options then "all transitive ", all_build_dependencies env build_deps, all_scanner_dependencies env scanner_deps else "", build_deps, scanner_deps in Format.fprintf buf "@[target: %a@ @[%sscanner dependencies:%a@]@ @[static dependencies:%a@]@ @[%sbuild dependencies:%a@]@ @[dependencies are merged from:%a@]@ @[targets that depend on this node at this point:%a@]@]" (**) Omake_node.pp_print_node target total Omake_node.pp_print_node_set scanner_deps Omake_node.pp_print_node_set static_deps total Omake_node.pp_print_node_set build_deps Omake_node.pp_print_node_set effects Omake_node.pp_print_node_set inverse; if show_all && Omake_options.opt_verbose_dependencies options then let nodes = Omake_node.NodeSet.union scanner_deps build_deps in Format.fprintf buf "@ @ --- Complete dependency listing ---@ "; Omake_node.NodeSet.iter (fun node -> let command = find_command env node in Format.fprintf buf "@ %a" (pp_print_dependencies_aux false env) command) nodes let pp_print_dependencies = pp_print_dependencies_aux true (* * Reclassify the commands. *) let reclassify_command (env : Omake_build_type.t) (command : Omake_build_type.command) (state : Omake_build_type.command_state) = (* Unlink the node from its current list *) let pred = command.command_pred in let succ = !(command.command_succ) in let _ = pred := succ; match succ with Some next -> next.Omake_build_type.command_pred <- pred | None -> () in (* Update the job counter *) let incr = match command.command_state, state with CommandSucceeded _, CommandSucceeded _ -> 0 | CommandSucceeded _, _ -> -1 | _, CommandSucceeded _ -> 1 | _ -> 0 in let () = env.env_succeeded_count <- env.env_succeeded_count + incr in (* Add to the new list *) let l = Omake_build_util.command_worklist env (Omake_build_util.command_tag state) in let next = !l in l := Some command; command.command_state <- state; command.command_pred <- l; command.command_succ := next; match next with Some next -> next.command_pred <- command.command_succ | None -> () (************************************************************************ * Other target utilities. *) let target_is_phony = Omake_node.Node.is_phony let target_exists (env : Omake_build_type.t) node = Omake_cache.exists env.env_cache node let target_is_buildable (env : Omake_build_type.t) venv node = Omake_target.target_is_buildable env.env_cache venv node let env_options (env : Omake_build_type.t) = Omake_env.venv_options env.env_venv (* * Add a target to the print-dependency list. * The target dependencies will be printed just before the * build rule is executed. *) let print_node_dependencies (env : Omake_build_type.t ) target = env.env_print_dependencies <- Omake_node.NodeSet.add env.env_print_dependencies target (* * Start command if it is idle. *) let start_command env (command : Omake_build_type.command) = if command.command_state = CommandIdle then reclassify_command env command CommandInitial (* * Find a process by pid. *) let find_pid env pid = Omake_build_util.command_find env CommandRunningTag (fun command -> match command.command_state with CommandRunning (pid', _) -> pid' = pid | _ -> false) (* * Get the command lines. *) let command_lines (command : Omake_build_type.command) = match command.command_lines with | CommandNone -> [], None | CommandScanner (_, _, lines, digest) | CommandLines (_, lines, digest) -> lines, digest | CommandInfo _ -> raise (Invalid_argument "build_lines") (* * See if this is a scanner command. *) let command_is_scanner (command : Omake_build_type.command) = Omake_node.Node.kind command.command_target = NodeScanner let set_tee env (command : Omake_build_type.command) tee = Omake_node.NodeSet.iter (fun target -> Omake_build_tee.unlink_tee (find_command env target)) command.command_effects; Omake_build_tee.unlink_tee command; command.command_tee <- tee (************************************************************************ * Command creation. *) (* * Create a command for a target that always exists. *) let create_exists_command env _ loc target = (* Create the command, and link it to the worklist *) let l = Omake_build_util.command_worklist env CommandSucceededTag in let next = !l in let succ = ref next in let effects = Omake_node.NodeSet.singleton target in let command : Omake_build_type.command = { command_venv = env.env_venv; command_state = CommandSucceeded Omake_node.NodeTable.empty; command_target = target; command_locks = effects; command_effects = effects; command_scanner_deps = Omake_node.NodeSet.empty; command_static_deps = Omake_node.NodeSet.empty; command_build_deps = Omake_node.NodeSet.empty; command_blocked = []; command_loc = loc; command_lines = CommandNone; command_tee = Omake_exec_util.tee_none; command_pred = l; command_succ = succ } in (* Link it into the list *) l := Some command; (match next with Some next -> next.command_pred <- succ | None -> ()); (* Add to the command table *) env.env_optional_count <- env.env_optional_count + 1; env.env_commands <- Omake_node.NodeTable.add env.env_commands target command (* * Create a command for a squashed target, * where the digest value is ignored, but the * target should be built. *) let create_squashed_command env _ loc target = (* Create the command, and link it to the worklist *) let l = Omake_build_util.command_worklist env CommandInitialTag in let next = !l in let succ = ref next in let effects = Omake_node.NodeSet.singleton target in let static_deps = Omake_node.NodeSet.singleton (Omake_node.Node.core target) in let command : Omake_build_type.command = { command_venv = env.env_venv; command_state = CommandInitial; command_target = target; command_effects = effects; command_locks = static_deps; command_static_deps = static_deps; command_scanner_deps = Omake_node.NodeSet.empty; command_build_deps = Omake_node.NodeSet.empty; command_blocked = []; command_loc = loc; command_lines = CommandNone; command_tee = Omake_exec_util.tee_none; command_pred = l; command_succ = succ } in (* Link it into the list *) l := Some command; (match next with Some next -> next.command_pred <- succ | None -> ()); (* Add to the command table *) env.env_commands <- Omake_node.NodeTable.add env.env_commands target command (* * Create a command in a state. *) let create_command env venv target effects lock_deps static_deps scanner_deps loc _ commands = (* Create the command, and link it to the worklist *) let l = Omake_build_util.command_worklist env CommandInitialTag in let next = !l in let succ = ref next in let () = if not (Omake_node.NodeSet.for_all (fun node -> Omake_node.Node.kind node = NodeScanner) scanner_deps) then let print_error buf = Format.fprintf buf "@[Malformed scanner dependencies:"; Format.fprintf buf "@ target: %a" Omake_node.pp_print_node target; Format.fprintf buf "@ @[lock_deps:%a@]" Omake_node.pp_print_node_set lock_deps; Format.fprintf buf "@ @[static_deps:%a@]" Omake_node.pp_print_node_set static_deps; Format.fprintf buf "@ @[scanner_deps:%a@]" Omake_node.pp_print_node_set scanner_deps; Format.fprintf buf "@]" in raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, LazyError print_error)) in let effects = Omake_node.NodeSet.add effects target in let locks = Omake_node.NodeSet.union lock_deps effects in let command : Omake_build_type.command = { command_venv = venv; command_state = CommandInitial; command_target = target; command_effects = effects; command_locks = locks; command_static_deps = static_deps; command_scanner_deps = scanner_deps; command_build_deps = Omake_node.NodeSet.empty; command_blocked = []; command_loc = loc; command_lines = commands; command_tee = Omake_exec_util.tee_none; command_pred = l; command_succ = succ } in (* Link it into the list *) l := Some command; (match next with Some next -> next.command_pred <- succ | None -> ()); (* Add to the command table *) env.env_commands <- Omake_node.NodeTable.add env.env_commands target command (* * Build a command given a directory and a command list. *) let build_any_command (env : Omake_build_type.t) pos loc venv target effects locks sources scanners commands = let pos = Pos.string_pos "build_any_command" (Pos.loc_pos loc pos) in (* Directory for this target *) let dir = Omake_env.venv_dir venv in (* Get all the extra dependencies that are statically defined *) let lock_deps, static_deps, scanner_deps = try Omake_node.NodeTable.find env.env_explicit_deps target with Not_found -> Omake_node.NodeSet.empty, Omake_node.NodeSet.empty, Omake_node.NodeSet.empty in let lock_deps = Omake_node.NodeSet.union lock_deps locks in let static_deps = Omake_node.NodeSet.union static_deps sources in let scanner_deps = Omake_node.NodeSet.union scanner_deps scanners in let implicit_lock_deps, implicit_static_deps, implicit_scanner_deps, implicit_values = Omake_env.venv_find_implicit_deps venv target in let lock_deps = Omake_node.NodeSet.union lock_deps implicit_lock_deps in let static_deps = Omake_node.NodeSet.union static_deps implicit_static_deps in let scanner_deps = Omake_node.NodeSet.union scanner_deps implicit_scanner_deps in let scanner_deps = if Omake_node.Node.kind target = NodeScanner || not (Omake_node.NodeSet.is_empty scanner_deps) then scanner_deps else let scanner_mode = venv_find_scanner_mode venv pos in if scanner_mode = IsDisabled then scanner_deps else let scanner_target = Omake_node.Node.create_escape NodeScanner target in if target_is_buildable env venv pos scanner_target then match scanner_mode with IsWarning -> Format.eprintf "*** omake: warning: using default scanner %a@." Omake_node.pp_print_node scanner_target; Omake_node.NodeSet.add scanner_deps scanner_target | IsError -> raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, StringNodeError ("default scanners are not allowed", scanner_target))) | IsEnabled -> Omake_node.NodeSet.add scanner_deps scanner_target | IsDisabled -> scanner_deps else scanner_deps in let () = if Lm_debug.debug debug_build then Format.eprintf "@[Building new rule: %s@ @[lock deps:%a@]@ @[static deps:%a@]@ @[scanner deps:%a@]@]@." (**) (Omake_node.Node.fullname target) Omake_node.pp_print_node_set lock_deps Omake_node.pp_print_node_set static_deps Omake_node.pp_print_node_set scanner_deps in let commands : Omake_build_type.command_body = match implicit_values, commands with | [], [] -> CommandNone | [], _ :: _ -> CommandInfo commands | _ :: _, _ -> let (command : Omake_env.command_info) = { command_env = venv; command_sources = Omake_node.NodeSet.to_list sources; command_values = implicit_values; command_body = [] } in CommandInfo (command :: commands) in create_command env venv target effects lock_deps static_deps scanner_deps loc dir commands (* * Build a null command for a file that exists but has no * build rules. *) let build_null_command env pos loc venv target = let pos = Pos.string_pos "build_null_command" pos in if Lm_debug.debug Omake_env.debug_implicit then Format.eprintf "build_null_command: %a@." Omake_node.pp_print_node target; if target_is_phony target || target_exists env target then begin build_any_command env pos loc venv target Omake_node.NodeSet.empty Omake_node.NodeSet.empty Omake_node.NodeSet.empty Omake_node.NodeSet.empty []; if Omake_options.opt_poll (env_options env) && not (target_is_phony target) then Omake_exec.Exec.monitor env.env_exec target end else raise (UnknownTarget target) (* * Build a command from an environment, a set of sources, and * a list of commands. *) let build_explicit_command (env : Omake_build_type.t) pos loc target effects locks venv sources scanners commands = let pos = Pos.string_pos "build_explicit_command" pos in let () = if Lm_debug.debug Omake_env.debug_implicit then Format.eprintf "@[build_explicit_command: explicit rule %a:@ @[effects =%a@]@ @[sources =%a@]@ @[scanners =%a@]@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set effects Omake_node.pp_print_node_set sources Omake_node.pp_print_node_set scanners in (* Check that all the effects have the same environment *) let bogus = Omake_node.NodeSet.fold (fun bogus effect -> try let erule = Omake_node.NodeTable.find env.env_explicit_targets effect in if erule.rule_env != venv then Omake_node.NodeSet.add bogus effect else bogus with Not_found -> bogus) Omake_node.NodeSet.empty effects in let _ = if not (Omake_node.NodeSet.is_empty bogus) then let pp_print_target_loc buf (target, loc) = Format.fprintf buf "@ @[%a@ (%a)@]" Omake_node.pp_print_node target Lm_location.pp_print_location loc in let rec pp_print_bogus_set buf bogus = if not (Omake_node.NodeSet.is_empty bogus) then begin let effect = Omake_node.NodeSet.choose bogus in pp_print_target_loc buf (effect, (Omake_node.NodeTable.find env.env_explicit_targets effect).rule_loc); pp_print_bogus_set buf (Omake_node.NodeSet.remove bogus effect) end in Format.eprintf "@[*** omake:@ These file are targeted separately, but appear as effects of a single rule.@ This is likely to lead to unpredictable behavior.@ @[targets:%a%a@]@]@." (**) pp_print_target_loc (target, loc) pp_print_bogus_set bogus in build_any_command env pos loc venv target effects locks sources scanners commands (* * Build a command from a set of implicit rules. * We choose the first rule where the dependencies can be satisfied. *) let build_implicit_command (env : Omake_build_type.t) pos loc target venv = let pos = Pos.string_pos "build_implicit_command" pos in match Omake_target.venv_find_buildable_implicit_rule env.env_cache venv pos target with Some { rule_loc = loc; rule_effects = effects; rule_locks = locks; rule_sources = sources; rule_scanners = scanners; rule_commands = commands; _ } -> build_explicit_command env pos loc target effects locks venv sources scanners commands | None -> build_null_command env pos loc venv target (* * Build a command from an explicit rule. * The rule defines an environment that we can use * to find the scanner, and extra dependencies. * * If the erule specifies some commands, use them. * Otherwise, find an implicit rule to use. *) let build_explicit_target env pos _ target erule = let pos = Pos.string_pos "build_explicit_target" pos in match Omake_rule.expand_rule erule with { rule_loc = loc; rule_env = venv; rule_effects = effects; rule_locks = locks; rule_sources = sources; rule_scanners = scanners; rule_commands = commands; _ } -> if commands = [] then build_implicit_command env pos loc target venv else build_explicit_command env pos loc target effects locks venv sources scanners commands (* * Create a new command for the target. *) let build_command_non_escaped (env : Omake_build_type.t) pos loc target = let pos = Pos.string_pos "build_command_non_escaped" pos in (* * If the target has an explicit rule, use it. * Otherwise, this is a leaf in the dependency tree. *) let erule = try Omake_build_type.ExplicitTarget (Omake_node.NodeTable.find env.env_explicit_targets target) with Not_found -> let target_dir = Omake_node.Node.dir target in try ExplicitDirectory (Omake_node.DirTable.find env.env_explicit_directories target_dir) with Not_found -> ExplicitNone in match erule with ExplicitTarget erule -> build_explicit_target env pos loc target erule | ExplicitDirectory venv -> build_implicit_command env pos loc target venv | ExplicitNone -> build_null_command env pos loc env.env_venv target (* * Create a new command for the scanner target. The difference is * that the scanner uses the dependent environment unless it is explicit. *) let build_scanner_command (env : Omake_build_type.t) pos loc target venv = let pos = Pos.string_pos "build_scanner_command" pos in (* * If the target has an explicit rule, use it. * Otherwise, this is a leaf in the dependency tree. *) match (Omake_node.NodeTable.find env.env_explicit_targets target) with | erule -> build_explicit_target env pos loc target erule | exception Not_found -> build_implicit_command env pos loc target venv (* * If the node is escaped, just create it as succeeded. * If it is squashed, create a fake node that depends * on the original file. *) let build_command env pos loc target = let pos = Pos.string_pos "build_command" pos in let () = if Lm_debug.debug debug_build then Format.eprintf "@[Building command for: %s@]@." (Omake_node.Node.fullname target) in match Omake_node.Node.kind target with NodeOptional | NodeExists -> create_exists_command env pos loc target | NodeSquashed -> create_squashed_command env pos loc target | NodePhony | NodeNormal | NodeScanner -> build_command_non_escaped env pos loc target (* * Start commands, or build them. *) let start_or_build_commands env pos loc parent targets = let pos = Pos.string_pos "start_or_build_commands" pos in Omake_node.NodeSet.iter (fun target -> try start_command env (find_command env target) with Not_found -> (try build_command env pos loc target with UnknownTarget target -> let print_error buf = Format.fprintf buf "Do not know how to build \"%a\" required for \"%a\"" Omake_node.pp_print_node target Omake_node.pp_print_node parent in raise (Omake_value_type.OmakeException (pos, LazyError print_error)))) targets (* * Start scanners. The difference is that a scanner inherits * the environment of the parent, unless the scanner * target is explicit. *) let start_or_build_scanners env pos loc parent targets venv = let pos = Pos.string_pos "start_or_build_scanners" pos in Omake_node.NodeSet.iter (fun target -> try let command = find_command env target in (* if command.command_venv != venv then Format.eprintf "@[*** omake warning:@ @[scanner uses a different environment than the target@ %a:@]@ @[scanner definition:@ %a;@]@ @[current location:@ %a@]@]@." (**) Omake_node.pp_print_node target pp_print_location command.command_loc pp_print_location loc; *) start_command env command with Not_found -> (try build_scanner_command env pos loc target venv with UnknownTarget target -> let print_error buf = Format.fprintf buf "Do not know how to build \"%a\" required for \"%a\"" Omake_node.pp_print_node target Omake_node.pp_print_node parent in raise (Omake_value_type.OmakeException (pos, LazyError print_error)))) targets (* * Make sure the effect sets form equivalence classes. * Every command in the effect set should have the * same effects. *) let start_or_build_effects env pos loc target effects = let pos = Pos.string_pos "start_or_build_effects" pos in let step effects = start_or_build_commands env pos loc target effects; Omake_node.NodeSet.fold (fun (changed, effects) effect -> let command = find_command env effect in let effects' = command.command_effects in if effects' == effects then changed, effects else let effects = Omake_node.NodeSet.union effects effects' in command.command_effects <- effects; true, effects) (false, effects) effects in let rec fixpoint effects = let changed, effects = step effects in if changed then fixpoint effects in fixpoint effects (* * Catch errors. *) let build_command env pos loc target = try build_command env pos loc target with UnknownTarget _ -> raise (Omake_value_type.OmakeException (pos, StringNodeError ("Do not know how to build", target))) (************************************************************************ * Dependency management *) (* * Add inverse entries from the command, * and set the blocked queue. *) let command_set_blocked (env : Omake_build_type.t) (command : Omake_build_type.command) deps = match command with { command_target = target ; _} -> let inverse = Omake_node.NodeSet.fold (fun inverse dep -> Omake_node.NodeTable.filter_add inverse dep (fun commands -> let commands = match commands with Some commands -> commands | None -> Omake_node.NodeTable.empty in Omake_node.NodeTable.add commands target command)) env.env_inverse deps in env.env_inverse <- inverse; command.command_blocked <- Omake_node.NodeSet.to_list deps (* * Add the build deps. *) let command_set_build_deps env command deps = command_set_blocked env command deps; command.command_build_deps <- deps (* * Check if the command overlaps with a running process. *) let command_conflicts_with_running (env : Omake_build_type.t) (command : Omake_build_type.command) = let locks = command.command_locks in Omake_build_util.command_exists env CommandRunningTag (fun command -> Omake_node.NodeSet.exists (Omake_node.NodeSet.mem locks) command.command_locks) false (* * Check if a command succeeded. *) let command_succeeded (command : Omake_build_type.command) = match command with | { command_state = CommandSucceeded _; _ } -> true | _ -> false (* * Command is blocked until all dependencies have been built. *) let command_is_blocked (env : Omake_build_type.t) (command : Omake_build_type.command) = match command with { command_blocked = blocked ; _} -> if blocked = [] then false else let rec process_blocked env deps = match deps with dep :: deps' -> if command_succeeded (find_command env dep) then process_blocked env deps' else deps | [] -> [] in let blocked = process_blocked env blocked in command.command_blocked <- blocked; blocked <> [] (* * Check if all effects that are not the target have been scanned. *) let command_effects_are_scanned (env : Omake_build_type.t) (command : Omake_build_type.command) = match command with { command_target = target; command_effects = effects; _ } -> Omake_node.NodeSet.for_all (fun effect -> if Omake_node.Node.equal effect target then true else match (find_command env effect).command_state with | CommandScannedPending | CommandSucceeded _ -> true | _ -> false) effects (* * Reclassify dependent rules. *) let enable_parents (env : Omake_build_type.t) (command : Omake_build_type.command) = let enable_parent _ command = if not (command_is_blocked env command) then let state : Omake_build_type.command_state = match command.command_state with | CommandScanBlocked -> if command_effects_are_scanned env command then CommandScanned else CommandScannedPending | CommandBlocked -> CommandReady | state -> state in reclassify_command env command state in let parents = try Omake_node.NodeTable.find env.env_inverse command.command_target with Not_found -> Omake_node.NodeTable.empty in Omake_node.NodeTable.iter enable_parent parents (************************************************************************ * Generic execution. *) (* * Parse the dependency list. *) let parse_deps _ venv target file = let deps = Omake_eval.compile_deps venv target file in if !debug_deps then begin Format.eprintf "@[Scanner: %s" file; List.iter (fun (targets, sources) -> Format.eprintf "@ @[@[targets ="; List.iter (fun target -> Format.eprintf "@ %s" target) targets; Format.eprintf "@]@ @[sources ="; List.iter (fun source -> Format.eprintf "@ %s" source) sources; Format.eprintf "@]@]") deps; Format.eprintf "@]@." end; List.fold_left (fun table (targets, sources) -> let sources = List.fold_left (fun set s -> let node = Omake_env.venv_intern venv PhonyOK s in Omake_node.NodeSet.add set node) Omake_node.NodeSet.empty sources in List.fold_left (fun table target -> let target = Omake_env.venv_intern venv PhonyOK target in Omake_node.NodeTable.filter_add table target (fun set -> match set with Some set -> Omake_node.NodeSet.union set sources | None -> sources)) table targets) Omake_node.NodeTable.empty deps (* * A command finished with an error. *) let abort_command env command code = if Omake_options.opt_terminate_on_error (env_options env) then env.env_error_code <- code; Omake_build_tee.env_close_failed_tee env command; reclassify_command env command (CommandFailed code) let abort_commands env targets code = if Omake_options.opt_terminate_on_error (env_options env) then env.env_error_code <- code; Omake_node.NodeSet.iter (fun target -> reclassify_command env (find_command env target) (CommandFailed code)) targets (************************************************************************ * Scanner execution. *) (* * All scanner subgoals have finished, and all effects * have been scanned too. Take the union of all the dependencies. *) let finish_scanned (env : Omake_build_type.t) (command : Omake_build_type.command) = match command with { command_loc = loc; command_target = target; command_effects = effects; _ } -> let pos = Pos.loc_exp_pos loc in (* Get the command for each of the effects *) let effects_commands = Omake_node.NodeSet.fold (fun commands command -> find_command env command :: commands) [] effects in (* Find all the scanner results *) let scanner_deps = List.fold_left (fun scanner_deps (command : Omake_build_type.command) -> Omake_node.NodeSet.union scanner_deps command.command_scanner_deps) Omake_node.NodeSet.empty effects_commands in let dep_tables = Omake_node.NodeSet.fold (fun dep_tables scanner -> let scan_command = find_command env scanner in match scan_command.command_state with CommandSucceeded table -> table :: dep_tables | _ -> let print_error buf = Format.fprintf buf "@[Internal error in Omake_build.finish_scanned:@ %a@ %a@ @[Effects:%a@]@]" (**) Omake_build_util.pp_print_command command Omake_build_util.pp_print_command scan_command (Omake_build_util.pp_print_node_states env) effects in raise (Omake_value_type.OmakeFatalErr (pos, LazyError print_error))) [] scanner_deps in (* Now collect all the deps *) let deps = List.fold_left (fun deps (command : Omake_build_type.command) -> match command with { command_target = target; command_static_deps = static_deps; command_scanner_deps = scanner_deps; _} -> let deps = Omake_node.NodeSet.union deps static_deps in let deps = Omake_node.NodeSet.union deps scanner_deps in List.fold_left (fun deps table -> try Omake_node.NodeSet.union deps (Omake_node.NodeTable.find table target) with Not_found -> deps) deps dep_tables) Omake_node.NodeSet.empty effects_commands in (* Make sure all the newly discovered dependencies have commands *) start_or_build_commands env pos loc target deps; (* Set the state of all the effects *) List.iter (fun (command : Omake_build_type.command) -> let target = command.command_target in (* Set the dependencies *) command_set_build_deps env command deps; (* Dependencies are final at this point *) if Omake_node.NodeSet.mem env.env_print_dependencies target then Format.eprintf "@[dependencies:@ %a@]@." (pp_print_dependencies env) command; (* Set the command state *) let state = if command_succeeded command then command.command_state else if command_is_blocked env command then CommandBlocked else CommandReady in reclassify_command env command state) effects_commands (* * A scanner has finished successfully. * Notify the parents. *) let finish_scanner env (command : Omake_build_type.command) scanned_deps = match command with {command_target = target; _} -> if Lm_debug.debug Omake_env.debug_scanner then Format.eprintf "@[finish_scanner %a:%a@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set_table scanned_deps; (* This command has been scanned *) reclassify_command env command (CommandSucceeded scanned_deps); (* Notify parents that something is done *) enable_parents env command (* * A scanner command finished successfully. * * XXX: HACK: Recompute the command digest if the scanner dependencies * have changed. * * This is probably a reasonable thing to do, but it means that the * rule text may be computed twice for .SCANNER rules. * * This could be wrong in two cases: * 1. If the .SCANNER body performs a side-effect while computing * the rule text. * 2. If the .SCANNER body depends non-trivially on the scanner * dependencies $&. *) let save_and_finish_scanner_results (env : Omake_build_type.t) (command : Omake_build_type.command) scanned_deps = (* Add the run to the cache *) match command with { command_loc = loc; command_venv = venv; command_target = target; command_lines = scanner; command_locks = locks; command_build_deps = build_deps; _ } -> (* Save in cache *) let cache = env.env_cache in let targets = Omake_node.NodeSet.singleton target in (* Re-stat the locks *) let () = Omake_node.NodeSet.iter (fun lock -> ignore (Omake_cache.force_stat cache lock)) locks in (* Recompute the scanner digest *) let digest = match scanner with CommandNone -> None | CommandLines (_, _, digest) -> digest | CommandScanner (info, sloppy_deps, _, digest) -> let deps = flatten_deps scanned_deps in if Omake_node.NodeSet.equal deps sloppy_deps then digest else let pos = Pos.loc_exp_pos loc in let scanner_commands = Omake_rule.eval_commands venv loc target deps info in let scanner_commands = List.map Omake_command.command_allow_output scanner_commands in Omake_command_digest.digest_of_commands pos scanner_commands | CommandInfo _ -> raise (Invalid_argument "scanner_lines") in Omake_cache.add cache scanner_fun target targets build_deps digest (MemoSuccess scanned_deps); finish_scanner env command scanned_deps (* * Add the run to the cache. *) let save_and_finish_scanner_success (env : Omake_build_type.t) (command : Omake_build_type.command) filename = match command with { command_loc = loc; command_venv = venv; command_target = target; _ } -> (* * Get the result. * The parser may still fail. *) let result = try let result = parse_deps env venv target filename in (* Remove the file as early as possible *) Lm_unix_util.try_unlink_file filename; Some result with Omake_value_type.OmakeException _ | Omake_value_type.UncaughtException _ | Failure _ | Not_found | Parsing.Parse_error | Sys_error _ -> None in match result with Some result -> if Lm_debug.debug Omake_env.debug_scanner then Format.eprintf "@[Saving dependencies: %a@ @[scanned deps:%a@]@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set_table result; Omake_build_tee.env_close_success_tee env command; save_and_finish_scanner_results env command result | None -> (* Don't remove the file, in case the user wants to look at it *) let pos = Pos.string_pos "save_and_finish_scanner" (Pos.loc_exp_pos loc) in let lines, _ = command_lines command in let shell = Omake_rule.eval_shell venv pos in let options = env_options env in let divert_only = not (Omake_options.opt_output options OutputNormal) in let handle_err = Omake_exec_util.tee_stderr command.command_tee divert_only Omake_exec_id.null_id in let out = Lm_printf.byte_formatter handle_err (fun () -> handle_err (Bytes.create 0) 0 0) in Format.fprintf out "@?*** omake: scanner produced ill-formed output@."; Omake_exec_print.pp_status_lines out options shell "scan" lines; Format.fprintf out "*** omake: @[scanner output is saved in@ %s@]@." filename; abort_command env command Omake_state.scanner_error_code (* The external command succeeded, but might still need to be postprocessed *) let save_and_finish_scanner_postprocess (env : Omake_build_type.t) (command : Omake_build_type.command) details = let open Omake_build_type in match details.scanner_post_action with | None -> save_and_finish_scanner_success env command details.scanner_out_file | Some (loc, apply) -> let venv = command.command_venv in let venv_opts = Omake_env.venv_options venv in let next_tmpfile = Filename.temp_file "omake_" ".deps" in let pos = Pos.loc_exp_pos loc in let options = Lm_glob.create_options (Omake_rule.glob_options_of_env venv pos) in let apply1 = Omake_rule.normalize_apply venv pos loc options apply in let apply2 = { apply1 with apply_stdin = RedirectArg details.scanner_out_file; apply_stdout = RedirectArg next_tmpfile; } in (* We create the tee for stderr. This is not a real tee, and we cannot emulate the mode where we both write to the temp file and write to stderr. AFAIK this mode isn't used. *) let tee = Omake_exec_util.tee_create (Omake_options.opt_divert venv_opts) in let stderr = match Omake_exec_util.tee_file_descr tee with | None -> Unix.stderr | Some fd -> fd in set_tee env command tee; let pseudo_pid = Omake_shell_job.create_process venv (PipeApply(loc, apply2)) Unix.stdin Unix.stdout stderr in Lm_unix_util.try_unlink_file details.scanner_out_file; ( match pseudo_pid with | ResultPid(_,_,v) -> ( match v with | Omake_value_type.ValOther(ValExitCode code) when code <> 0 -> raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, StringIntError ("command exited with code", code))) | _ -> () ) | _ -> assert false ); save_and_finish_scanner_success env command next_tmpfile (* * Failed run. *) let save_and_finish_scanner_failed env command filename code = Lm_unix_util.try_unlink_file filename; abort_command env command code let s_command cmd = match cmd. Omake_command_type.command_inst with | Omake_command_type.CommandEval _ -> "CommandEval" | Omake_command_type.CommandPipe _ -> "CommandPipe" | Omake_command_type.CommandValues _ -> "CommandValues" (* * Run the command. *) let execute_scanner (env : Omake_build_type.t) (command : Omake_build_type.command) = match command with { command_target = target; command_loc = loc; command_venv = venv; _ } -> let pos = Pos.string_pos "execute_scanner" (Pos.loc_exp_pos loc) in let scanner, _ = command_lines command in let tmpfile = Filename.temp_file "omake" ".deps" in (* Special-case a pipeline cmd1|cmd2 when cmd2 is a PipeApply (i.e. an internal command). We don't want to fork in this case as it is frequent. (This is for the "ocamldep | ocamldep-postproc" pipe.) We don't do this for Win32 where it only adds latencies. *) let scanner_values, scanner_rest = (* the CommandPipe may be preceded by CommandValues *) match scanner with | { command_inst = Omake_command_type.CommandValues _; _ } as v :: rest -> [v], rest | _ -> [], scanner in let eff_scanner, post_action = match scanner_rest with | [ { command_inst = Omake_command_type.CommandPipe( PipeCompose(_,false,cmd1,(PipeApply(loc,cmd2)))); _ } ] when Sys.os_type <> "Win32" -> scanner_values @ [ { (List.hd scanner_rest) with command_inst = Omake_command_type.CommandPipe cmd1 } ], Some(loc, cmd2) | _ -> scanner, None in let details = { Omake_build_type.scanner_out_file = tmpfile; scanner_post_action = post_action } in (* Save errors to the tee *) let options = Omake_env.venv_options venv in let tee = Omake_exec_util.tee_create (Omake_options.opt_divert options) in let divert_only = not (Omake_options.opt_output options OutputNormal) in let copy_stdout = Omake_exec_util.tee_stdout tee divert_only in let copy_stderr = Omake_exec_util.tee_stderr tee divert_only in (* Save output into a temporary file *) let handle_out = Omake_exec_util.copy_file tmpfile in (* Debugging *) let () = if Lm_debug.debug Omake_env.debug_scanner then Format.eprintf "@[run_scanner %a@ to tmp file %s:%a@]@." (**) Omake_node.pp_print_node target tmpfile Omake_env.pp_print_arg_command_lines eff_scanner in let shell = Omake_rule.eval_shell venv pos in set_tee env command tee; env.env_scan_exec_count <- succ env.env_scan_exec_count; match Omake_exec.Exec.spawn env.env_exec shell (Omake_env.venv_options venv) copy_stdout handle_out copy_stderr "scan" target eff_scanner with ProcessFailed -> (* The fork failed *) abort_command env command Omake_state.fork_error_code | ProcessStarted pid -> (* Process was started *) env.env_idle_count <- pred env.env_idle_count; reclassify_command env command (CommandRunning (pid, Some details)) (* * Execute a command. * Check with the cache to see if this command is already * up-to-date. *) let start_scanner (env : Omake_build_type.t) (command : Omake_build_type.command) = match command with { command_venv = venv; command_loc = loc; command_target = target; command_lines = scanner; command_build_deps = build_deps; _ } -> let pos = Pos.string_pos "start_scanner" (Pos.loc_exp_pos loc) in let sloppy_deps = try flatten_deps (Omake_cache.find_result_sloppy env.env_cache scanner_fun target) with Not_found -> Omake_node.NodeSet.empty in let scanner, scanner_digest = match scanner with CommandNone -> [], None | CommandInfo info -> assert (info <> []); let scanner_commands = Omake_rule.eval_commands venv loc target sloppy_deps info in let scanner_commands = List.map Omake_command.command_allow_output scanner_commands in let scanner_digest = Omake_command_digest.digest_of_commands pos scanner_commands in let info : Omake_build_type.command_body = if commands_have_value_dependencies info then CommandScanner (info, sloppy_deps, scanner_commands, scanner_digest) else CommandLines (info, scanner_commands, scanner_digest) in command.command_lines <- info; scanner_commands, scanner_digest | CommandScanner (_, _, lines, digest) | CommandLines (_, lines, digest) -> lines, digest in if scanner = [] then begin (* If scanner is empty, don't do anything *) if Lm_debug.debug Omake_env.debug_scanner then Format.eprintf "@[start_scanner: target has no scanner: %a@]@." Omake_node.pp_print_node target; save_and_finish_scanner_results env command Omake_node.NodeTable.empty end else begin (* Look up previous results from the cache *) env.env_scan_count <- succ env.env_scan_count; try let scanned_deps = Omake_cache.find_result env.env_cache scanner_fun build_deps scanner_digest in if Lm_debug.debug Omake_env.debug_scanner then Format.eprintf "@[start_scanner: target dependencies are accurate %a:@ @[scanner's build deps:%a@]@ @[scanned deps:%a@]@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set build_deps Omake_node.pp_print_node_set_table scanned_deps; finish_scanner env command scanned_deps with Not_found -> execute_scanner env command end (************************************************************************ * Rule execution. *) (* * A command finished successfuly. *) let finish_rule_success env command = (* Get a list of all commands that might be updated *) reclassify_command env command (CommandSucceeded Omake_node.NodeTable.empty); enable_parents env command (* * A command remains failed. *) let finish_rule_failed env (command : Omake_build_type.command) code = match command with { command_effects = effects ; _} -> abort_commands env effects code (* * A command finished successfuly. *) let hexify_digest = function Some digest -> Lm_string_util.hexify digest | None -> "none" let save_and_finish_rule_success (env : Omake_build_type.t) (command : Omake_build_type.command) = (* Add the run to the cache *) match command with { command_loc = loc; command_target = target; command_effects = effects; command_locks = locks; command_build_deps = build_deps; _ } -> let cache = env.env_cache in let _, commands_digest = command_lines command in (* Collect the effects that are not phony, check that they were created *) let effects = Omake_node.NodeSet.fold (fun effects effect -> Omake_cache.reset cache effect; let effect_exists = Omake_cache.exists cache effect in if Omake_node.Node.is_phony effect then effects else if not effect_exists then begin abort_command env command Omake_state.exn_error_code; raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, StringNodeError ("rule failed to build its target", effect))) end else Omake_node.NodeSet.add effects effect) Omake_node.NodeSet.empty effects in (* Re-stat the locks *) Omake_node.NodeSet.iter (fun lock -> Omake_cache.reset cache lock; ignore(Omake_cache.exists cache lock) ) locks; (* Add a memo for a specific target *) if Lm_debug.debug debug_rule then Format.eprintf "@[saving %a:@ @[build-deps:%a@]@ @[effects:%a@]@ digest: %s@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set build_deps Omake_node.pp_print_node_set effects (hexify_digest commands_digest); (* Add the memo only if the target is not phony *) if not (Omake_node.NodeSet.is_empty effects) then Omake_cache.add cache rule_fun target effects build_deps commands_digest (MemoSuccess Omake_node.NodeTable.empty); (* Remove the tees *) Omake_build_tee.env_close_success_tee env command; (* Now tell parents that this job succeeded *) finish_rule_success env command (* * A command failed. *) let save_and_finish_rule_failed (env : Omake_build_type.t) (command : Omake_build_type.command) code = (* Add the run to the cache *) match command with { command_target = target; command_effects = effects; command_build_deps = build_deps; _ } -> let cache = env.env_cache in let _, commands_digest = command_lines command in Omake_build_tee.env_close_failed_tee env command; Omake_cache.add cache rule_fun target effects build_deps commands_digest (MemoFailure code); abort_commands env effects code (* * Run the command. *) let run_rule (env : Omake_build_type.t) (command : Omake_build_type.command) = match command with { command_loc = loc; command_target = target; command_venv = venv; _ } -> let pos = Pos.string_pos "run_rule" (Pos.loc_exp_pos loc) in let commands, _ = command_lines command in let shell = Omake_rule.eval_shell venv pos in (* Set up the tee *) let options = Omake_env.venv_options venv in let tee = Omake_exec_util.tee_create (Omake_options.opt_divert options) in let divert_only = not (Omake_options.opt_output options OutputNormal) in let copy_stdout = Omake_exec_util.tee_stdout tee divert_only in let copy_stderr = Omake_exec_util.tee_stderr tee divert_only in set_tee env command tee; env.env_rule_exec_count <- succ env.env_rule_exec_count; match Omake_exec.Exec.spawn env.env_exec shell (Omake_env.venv_options venv) copy_stdout copy_stdout copy_stderr "build" target commands with ProcessFailed -> (* The fork failed *) abort_command env command Omake_state.fork_error_code | ProcessStarted pid -> (* The process was started *) env.env_idle_count <- pred env.env_idle_count; reclassify_command env command (CommandRunning (pid, None)) (* * Execute a command. * Check with the cache to see if this command is already * up-to-date. *) let execute_rule (env : Omake_build_type.t) (command : Omake_build_type.command) = match command with { command_loc = loc; command_target = target; command_effects = effects; command_lines = commands; command_build_deps = build_deps; command_venv = venv; _ } -> let pos = Pos.string_pos "execute_rule" (Pos.loc_exp_pos loc) in let options = Omake_env.venv_options venv in let commands, commands_digest = match commands with | CommandNone -> [], None | CommandScanner (_, _, lines, digest) | CommandLines (_, lines, digest) -> lines, digest | CommandInfo info -> assert (info <> []); let commands = Omake_rule.eval_commands venv loc target build_deps info in let digest = Omake_command_digest.digest_of_commands pos commands in command.command_lines <- CommandLines (info, commands, digest); commands, digest in if Lm_debug.debug debug_rule then Format.eprintf "@[building %a:@ @[build-deps:%a@]@ @[effects:%a@]@ digest: %s@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set build_deps Omake_node.pp_print_node_set effects (hexify_digest commands_digest); if commands = [] then save_and_finish_rule_success env command else begin env.env_rule_count <- succ env.env_rule_count; match Omake_cache.up_to_date_status env.env_cache rule_fun build_deps commands_digest with StatusSuccess -> if Lm_debug.debug debug_rule then Format.eprintf "@[target %a is up to date:%a@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set build_deps; finish_rule_success env command | StatusFailure code -> if Lm_debug.debug debug_rule then Format.eprintf "@[target %a failure:%a@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set build_deps; finish_rule_failed env command code | StatusUnknown -> if Omake_options.opt_touch_only options then begin if Omake_options.opt_print_file options then Lm_printf.printf "updating %a@." Omake_node.pp_print_node target; save_and_finish_rule_success env command end else if options.dry_run then begin if Omake_options.opt_print_command options <> EvalNever then List.iter (fun command -> if not (List.mem Omake_command_type.QuietFlag command.Omake_command_type.command_flags) then Lm_printf.printf "+ %a@." Omake_env.pp_print_arg_command_inst command.Omake_command_type.command_inst) commands; save_and_finish_rule_success env command end else begin if Lm_debug.debug debug_rule then Format.eprintf "@[running %a:%a@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set build_deps; run_rule env command end end (************************************************************************ * Saved versions. *) (* * Create a new, empty environment. *) let empty_env venv cache exec ~summary deps targets dirs includes : Omake_build_type.t= let cwd = Omake_node.Dir.cwd () in let options = Omake_env.venv_options venv in let wl = Omake_build_util.create_wl () in { env_venv = venv; env_cwd = cwd; env_cache = cache; env_exec = exec; env_explicit_deps = deps; env_explicit_targets = targets; env_explicit_directories = dirs; env_includes = includes; env_commands = Omake_node.NodeTable.empty; env_inverse = Omake_node.NodeTable.empty; env_error_code = 0; env_idle_count = Omake_options.opt_job_count options; env_print_dependencies = Omake_node.NodeSet.empty; env_current_wl = wl; env_main_wl = wl; env_pending_events = Queue.create (); env_summary = summary; env_optional_count = 0; env_succeeded_count = 0; env_scan_count = 0; env_scan_exec_count = 0; env_rule_count = 0; env_rule_exec_count = 0 } let create exec venv cache summary = match Omake_env.venv_explicit_rules venv with { explicit_targets = target_table; explicit_directories = dir_table; explicit_deps = dep_table; _ } -> let includes = Omake_env.venv_files venv in let includes = Omake_cache.stat_set cache includes in empty_env venv cache exec ~summary dep_table target_table dir_table includes (************************************************************************ * Saving state to .omakedb *) let pid = Unix.getpid () (* this is the PID of the main thread *) (* * Save the cache and environment to a file. *) let save_aux (env : Omake_build_type.t) = (* Only the "master" thread should be saving the DB *) if (pid <> Unix.getpid ()) then begin Format.eprintf "@[*** OMake Internal ERROR:@ Slave thread %i trying to save db opened by the master thread %i@]@." (Unix.getpid ()) pid; raise (Invalid_argument "Internal error: Slave thread trying to save the OMake DB") end; (* Save the static values *) let () = Omake_env.venv_save_static_values env.env_venv in (* Save the .omakedb *) let cache = env.env_cache in Omake_cache.process_delayed_digests cache; (* We want the name to be fairly unique in case locking had failed us. *) let db_tmp = Lm_printf.sprintf ".#%s.%s.%i" Omake_state.db_name (Unix.gethostname ()) pid in (* Marshal the state to the output file *) let outx = Pervasives.open_out_bin db_tmp in let includes = Omake_node.NodeTable.fold (fun includes node _ -> Omake_node.NodeSet.add includes node) Omake_node.NodeSet.empty env.env_includes in let targets = Omake_node.NodeSet.singleton env_target in try Omake_cache.add cache env_fun env_target targets includes None (MemoSuccess Omake_node.NodeTable.empty); Omake_cache.to_channel outx cache; close_out outx; Unix.rename db_tmp Omake_state.db_name with Unix.Unix_error (errno, name, arg) -> Format.eprintf "*** omake: failure during saving: %s: %s(%s)@." (Unix.error_message errno) name arg; close_out outx; Lm_unix_util.try_unlink_file db_tmp | Sys_error _ | Failure _ as exn -> Format.eprintf "*** omake: failure during saving: %s@." (Printexc.to_string exn); close_out outx; Lm_unix_util.try_unlink_file db_tmp (* * Save to the .omakedb. *) let save env = if not (env_options env).dry_run then try save_aux env with Sys_error _ as exn -> Format.eprintf "*** omake: failure during saving: %s@." (Printexc.to_string exn) (************************************************************************ * Invalidation. *) (* * Forms for walking up and down the tree. *) let invalidate_parents env (command : Omake_build_type.command) = find_parents env command.command_target let invalidate_children _ (command : Omake_build_type.command) = command.command_build_deps (* * General invalidation function. * * The invalidate_next function determines how to walk the tree. *) let rec invalidate_aux invalidate_next env nodes = if not (Omake_node.NodeSet.is_empty nodes) then let node = Omake_node.NodeSet.choose nodes in let command = find_command env node in let nodes = if command.command_state <> CommandInitial then let nodes = Omake_node.NodeSet.union nodes command.command_effects in let nodes = Omake_node.NodeSet.union nodes (invalidate_next env command) in (* Recompute the commands if they have value dependencies *) let () = match command.command_lines with CommandScanner (info, _, _, _) | CommandLines (info, _, _) -> command.command_lines <- CommandInfo info | CommandInfo _ | CommandNone -> () in (* Move the command back to the initial state *) reclassify_command env command CommandInitial; nodes else nodes in invalidate_aux invalidate_next env (Omake_node.NodeSet.remove nodes node) let invalidate_ancestors = invalidate_aux invalidate_parents let invalidate_children = invalidate_aux invalidate_children (************************************************************************ * Command management. *) (* * Process a command in the Initial state. * Check the dependencies. For each dependency, * make sure there is a command to build it. * If the dependencies are all finished, then * schedule this command for scanning. *) let process_initial env = let command = Omake_build_util.command_list_head env CommandInitialTag in match command with { command_loc = loc; command_venv = venv; command_target = target; command_effects = effects; command_scanner_deps = scanner_deps; command_static_deps = static_deps; _ } -> let pos = Pos.string_pos "process_initial" (Pos.loc_exp_pos loc) in let _ = if Lm_debug.debug debug_build then Format.eprintf "@[Process initial: %a@ @[scanner deps:%a@]@ @[static deps:%a@]@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set scanner_deps Omake_node.pp_print_node_set static_deps in (* Add commands for all the dependencies *) start_or_build_commands env pos loc target static_deps; start_or_build_scanners env pos loc target scanner_deps venv; (* Take the union of all the effects *) if Omake_node.NodeSet.cardinal effects > 1 then start_or_build_effects env pos loc target effects; (* Initially, we enter scanning mode *) command_set_blocked env command scanner_deps; let state : Omake_build_type.command_state = if command_is_blocked env command then CommandScanBlocked else if command_effects_are_scanned env command then CommandScanned else CommandScannedPending in reclassify_command env command state (* * A command has been scanned successfully. *) let process_scanned env = let command = Omake_build_util.command_list_head env CommandScannedTag in finish_scanned env command (* * Process a command in the Ready state. * Start it and place it on the run queue. *) let process_ready env = let command = Omake_build_util.command_list_head env CommandReadyTag in if command_conflicts_with_running env command then reclassify_command env command CommandPending else if command_is_scanner command then start_scanner env command else execute_rule env command (* * A command has just finished, so check each pending * process and move it to the ready queue if it no * longer conflicts with a running process. *) let process_pending env = Omake_build_util.command_iter env CommandPendingTag (fun command -> if not (command_conflicts_with_running env command) then reclassify_command env command CommandReady) (* * Leaf dependency - a leaf node, or a node that appears as optional/exists node *) let is_leaf_file (env : Omake_build_type.t) node = if Omake_node.NodeTable.mem env.env_commands node then Omake_build_util.is_leaf_node env node else (Omake_node.NodeTable.mem env.env_commands (Omake_node.Node.create_escape NodeOptional node) || Omake_node.NodeTable.mem env.env_commands (Omake_node.Node.create_escape NodeExists node)) (* * Process the running queue. * Wait until a process exits. *) let rec process_running (env : Omake_build_type.t) notify = let onblock() = Omake_cache.process_delayed_digests env.env_cache in match Omake_exec.Exec.wait ~onblock env.env_exec (env_options env) with WaitExited (pid, code, _) -> begin env.env_idle_count <- succ env.env_idle_count; try let command = find_pid env pid in let () = match code, command with 0, { command_state = CommandRunning (_, None) ; _} -> save_and_finish_rule_success env command | _, { command_state = CommandRunning (_, None) ; _} -> save_and_finish_rule_failed env command code | 0, { command_state = CommandRunning (_, Some detail) ; _} -> save_and_finish_scanner_postprocess env command detail | _, { command_state = CommandRunning (_, Some detail) ; _} -> let filename = detail.scanner_out_file in save_and_finish_scanner_failed env command filename code | _ -> raise (Invalid_argument "process_running") in process_pending env with Not_found -> () end | WaitServer additional_jobs -> if !Omake_exec_remote.debug_remote then Format.eprintf "# new idle count: %d + %d@." env.env_idle_count additional_jobs; env.env_idle_count <- env.env_idle_count + additional_jobs | WaitNotify event -> if notify then ignore (invalidate_event env event) | WaitNone -> () (* * Wait for all jobs to finish. *) and wait_all env verbose = if not (Omake_build_util.command_list_is_empty env CommandRunningTag) then begin if verbose then Format.eprintf "*** omake: waiting for all jobs to finish@."; ignore (process_running env false); wait_all env false end (************************************************************************ * Invalidation when a file is updated. *) (* * If the event is really a file change and it refers to a leaf * node, reset the command and all its ancestors to the initial state. *) and invalidate_event_core env node = let verbose = Omake_options.opt_print_status (env_options env) in if verbose then begin Omake_exec_print.progress_flush (); Format.eprintf "*** omake: file %s changed@." (Omake_node.Node.fullname node) end; (* If this is an OMakefile, abort and restart *) if Omake_node.NodeTable.mem env.env_includes node then begin wait_all env verbose; raise (Restart None) end else let nodes = if Omake_build_util.is_leaf_node env node then Omake_node.NodeSet.singleton node else Omake_node.NodeSet.empty in let nodes = Omake_node.NodeSet.union nodes (find_parents env (Omake_node.Node.create_escape NodeOptional node)) in let nodes = Omake_node.NodeSet.union nodes (find_parents env (Omake_node.Node.create_escape NodeExists node)) in invalidate_ancestors env nodes and do_invalidate_event env event = process_changes (is_leaf_file env) (invalidate_event_core env) env.env_venv env.env_cwd env.env_cache event (* * Block FAM events during when performing a build phase * (like .BUILD_BEGIN, .BUILD_SUCCESS, etc.). *) and invalidate_event env event = if env.env_current_wl != env.env_main_wl then begin (* Don't let the queue get too large *) if Queue.length env.env_pending_events < max_pending_events then Queue.add event env.env_pending_events; false end else do_invalidate_event env event (************************************************************************ * Loading state from .omakedb *) let notify_wait_simple venv cwd exec cache = Format.eprintf "*** omake: polling for filesystem changes (OMakefiles only)@."; let files = Omake_env.venv_files venv in let () = Omake_node.NodeSet.iter (fun node -> ignore (Omake_cache.stat cache node); Omake_exec.Exec.monitor exec node) files in let print_msg = if Omake_options.opt_print_status (Omake_env.venv_options venv) then fun node -> Lm_printf.printf "*** omake: file %s changed@." (Omake_node.Node.fullname node) else fun _ -> () in let rec loop changed = let event = Omake_exec.Exec.next_event exec in let changed = changed || process_changes (Omake_node.NodeSet.mem files) print_msg venv cwd cache event in if (not changed || Omake_exec.Exec.pending exec) then loop changed in loop false let print_restart options reason = if Omake_options.opt_print_status options then let reason = match reason with | None -> "a configuration file changed" | Some reason -> reason in Lm_printf.printf "*** omake: %s, restarting@." reason (* * Create and parse, given a cache. *) let create_env exec options cache targets = let venv = Omake_env.create options "." exec cache in let venv = Omake_builtin.venv_add_command_defs venv in let targets_value : Omake_value_type.t = ValArray (List.map (fun v -> Omake_value_type.ValData v) targets) in let venv = Omake_env.venv_add_var venv Omake_var.targets_var targets_value in let venv = Omake_builtin.venv_add_builtins venv in (* Summary file *) let summary = let summary, outx = Filename.open_temp_file ~mode:[Open_binary] "omake" ".error" in Pervasives.close_out outx; summary in let summary_value : Omake_value_type.t = ValNode (Omake_env.venv_intern venv PhonyProhibited summary) in let venv = Omake_env.venv_add_var venv Omake_var.build_summary_var summary_value in (* Ignore match errors *) let venv = Omake_env.venv_add_var venv Omake_var.glob_options_var (ValString "n") in (* Start reading files *) let now = Unix.gettimeofday () in let cwd = Omake_env.venv_dir venv in let () = if Omake_options.opt_print_dir options then Lm_printf.printf "make[0]: Entering directory `%s'@." (Omake_node.Dir.absname cwd); if Omake_options.opt_print_status options then begin Lm_printf.printf "*** omake: reading %ss@." Omake_state.makefile_name end in let venv = try let venv = Omake_builtin.venv_include_rc_file venv Omake_state.omakeinit_file in let venv = Omake_builtin.venv_add_pervasives venv in let venv = Omake_builtin.venv_include_rc_file venv Omake_state.omakerc_file in Omake_eval.compile venv; venv with exn -> Omake_env.venv_save_static_values venv; if Omake_options.opt_poll options && restartable_exn exn && not (Omake_node.NodeSet.is_empty (Omake_env.venv_files venv)) then begin if Omake_options.opt_print_status options then begin let now' = Unix.gettimeofday () in Lm_printf.printf "*** omake: reading %ss failed (%a)@." Omake_state.makefile_name Lm_unix_util.pp_time (now' -. now); end; Format.eprintf "%a@." Omake_exn_print.pp_print_exn exn; notify_wait_simple venv cwd exec cache; raise (Restart None) end else begin Lm_unix_util.try_unlink_file summary; raise exn end in let () = if Omake_options.opt_print_status options then let now' = Unix.gettimeofday () in Lm_printf.printf "*** omake: finished reading %ss (%a)@." Omake_state.makefile_name Lm_unix_util.pp_time (now' -. now) in let env = create exec venv cache summary in Omake_build_util.set_env env; env let rec create_env_loop exec options cache targets = try create_env exec options cache targets with Restart reason -> print_restart options reason; create_env_loop exec options cache targets (* * Load the environment if possible. * If not, create a new one. *) let load_omake options targets = let cwd = Omake_node.Dir.cwd () in let exec = Omake_exec.Exec.create cwd options in let cache = match (* Load cache from the db file *) try let inx = open_in_bin Omake_state.db_name in let cache = try Omake_cache.from_channel options inx with exn -> close_in inx; raise exn in close_in inx; Some cache with Unix.Unix_error _ | End_of_file | Sys_error _ | Failure _ -> None with None -> Omake_cache.create () | Some cache -> cache in create_env_loop exec options cache targets (* * Special version for use by osh. * We assume the starting directory for osh is the project root. *) let load_osh venv options targets = (* Replace the cache *) let cache = try let inx = open_in_bin Omake_state.db_name in Lm_unix_util.finally inx (Omake_cache.from_channel options ) close_in with | Unix.Unix_error _ | End_of_file | Sys_error _ |Failure _ -> Omake_cache.create () in let venv = Omake_env.venv_add_cache venv cache in (* Add the targets *) let targets_value : Omake_value_type.t = ValArray (List.map (fun v -> (ValData v : Omake_value_type.t )) targets) in let venv = Omake_env.venv_add_var venv Omake_var.targets_var targets_value in (* Add the summary file *) let summary = let summary, outx = Filename.open_temp_file ~mode:[Open_binary] "omake" ".error" in Pervasives.close_out outx; summary in let summary_value : Omake_value_type.t = ValNode (Omake_env.venv_intern venv PhonyProhibited summary) in let venv = Omake_env.venv_add_var venv Omake_var.build_summary_var summary_value in (* Create the environment *) let exec = Omake_env.venv_exec venv in let env = create exec venv cache summary in Omake_build_util.set_env env; env let load venv_opt options targets = match venv_opt with | Some venv -> load_osh venv options targets | None -> load_omake options targets let rec main_loop env (progress : prompt_state) = if Lm_debug.debug debug_build then Omake_build_util.eprint_env env ; let progress : prompt_state = let flushed = Omake_exec_print.progress_flushed () in if flushed || progress.count <> env.env_succeeded_count then let progress = { progress with count = env.env_succeeded_count } in let options = Omake_env.venv_options env.env_venv in let now = Unix.gettimeofday () in let will_save = ! save_interval > 0.0 && now > progress.save in let progress = if will_save then begin save env; Omake_exec_print.print_saving options; { progress with save = now +. ! save_interval } end else progress in if flushed || will_save || now > progress.progress then begin let total = Omake_node.NodeTable.cardinal env.env_commands - env.env_optional_count in Omake_exec_print.print_progress options env.env_succeeded_count total; { progress with progress = now +. prompt_interval } end else progress else progress in if not (Omake_build_util.command_list_is_empty env CommandInitialTag) then begin process_initial env; main_loop env progress end else if not (Omake_build_util.command_list_is_empty env CommandScannedTag) then begin process_scanned env; main_loop env progress end else if (env.env_idle_count > 0) && (env.env_error_code = 0) && not (Omake_build_util.command_list_is_empty env CommandReadyTag) then begin process_ready env; main_loop env progress end else if env.env_idle_count == 0 || not (Omake_build_util.command_list_is_empty env CommandRunningTag) then begin process_running env true; main_loop env progress end else begin assert (env.env_idle_count >= 0); Omake_exec_print.progress_flush () end (** Make the targets. *) let make (env : Omake_build_type.t) = let now = Unix.gettimeofday () in main_loop env { count = env.env_succeeded_count; progress = now +. prompt_interval; save = now +. !save_interval; } (* * Wait for notifications. *) let notify_wait (env : Omake_build_type.t) = match env with { env_exec = exec; env_venv = venv; _ } -> let db_node = Omake_env.venv_intern_cd venv PhonyProhibited (Omake_node.Dir.cwd ()) Omake_state.db_name in let rec loop found = if not found || Omake_exec.Exec.pending exec then let event = Omake_exec.Exec.next_event exec in let changed = invalidate_event env event in loop (changed || found) in Format.eprintf "*** omake: polling for filesystem changes@."; save env; ignore (Omake_cache.stat_changed env.env_cache db_node); Omake_build_util.unlock_db (); loop false; Omake_build_util.wait_for_lock (); if Omake_cache.stat_changed env.env_cache db_node then raise (Restart (Some "another OMake process have modified the build DB")); if Omake_options.opt_print_status (env_options env) then Format.eprintf "*** omake: rebuilding@." let notify_wait_omakefile env = Format.eprintf "*** omake: polling for filesystem changes (OMakefiles only)@."; let rec loop () = ignore (invalidate_event env (Omake_exec.Exec.next_event env.env_exec)); loop () in try loop () with Restart reason -> reason let print_summary ?(unlink = true) (env : Omake_build_type.t) = let inx = open_in_bin env.env_summary in let buffer = Bytes.create 256 in let rec copy () = let amount = input inx buffer 0 (Bytes.length buffer) in if amount > 0 then begin Pervasives.output Pervasives.stderr buffer 0 amount; copy () end in copy (); Pervasives.flush Pervasives.stderr; close_in inx; if unlink then Lm_unix_util.try_unlink_file env.env_summary (** Create or find a command to build it. *) let build_target env (print : bool) (target : Omake_node.NodeTable.key ) : unit = (try let command = find_command env target in start_command env command with Not_found -> let name = Omake_node.Node.fullname target in let loc = Lm_location.bogus_loc name in let pos = Pos.string_pos "build_target" (Pos.loc_exp_pos loc) in build_command env pos loc target); if print then print_node_dependencies env target (* * Worklist switching. * * Build a pseudo-phased target .BUILD_* with a fresh worklist. * The reason for switching worklists is so we don't damage the * main build, and also so that we ignore the main build * when executing phases. *) let build_phase (env : Omake_build_type.t) target : bool = let code = env.env_error_code in let restore_wl () = env.env_current_wl <- env.env_main_wl; if env.env_error_code = 0 then env.env_error_code <- code; Queue.iter (fun event -> ignore (do_invalidate_event env event)) env.env_pending_events; Queue.clear env.env_pending_events in Lm_unix_util.finally () (function () -> env.env_current_wl <- Omake_build_util.create_wl (); env.env_error_code <- 0; build_target env false target; invalidate_children env (Omake_node.NodeSet.singleton target); make env; Omake_build_util.command_list_is_empty env CommandFailedTag ) restore_wl (* * Build command line targets. *) let rec build_targets (env : Omake_build_type.t) save_flag start_time parallel print ?(summary = true) targets = let options : Omake_options.t = env_options env in (* * Summary management. *) let create_tmpfile (env : Omake_build_type.t) = close_out @@ Pervasives.open_out_gen [Open_wronly; Open_binary; Open_creat; Open_trunc] 0o600 env.env_summary in let () = try let begin_success = (* Build the initial summary *) not summary || (create_tmpfile env; build_phase env build_begin_target) in let process_summary () = (* Print out the final summary *) Lm_unix_util.with_file_fmt env.env_summary (fun buf -> if env.env_error_code <> 0 then begin Omake_build_util.print_stats env "failed" start_time; Omake_build_util.print_failed_targets env buf; false end else if not (Omake_build_util.command_list_is_empty env CommandBlockedTag) then begin Omake_build_util.print_stats env "blocked" start_time; Omake_build_util.print_failed env buf CommandBlockedTag; false end else if not (Omake_build_util.command_list_is_empty env CommandScanBlockedTag) then begin Omake_build_util.print_stats env "scanner is blocked" start_time; Omake_build_util.print_failed env buf CommandScanBlockedTag; false end else if not (Omake_build_util.command_list_is_empty env CommandFailedTag) then begin Omake_build_util.print_stats env "failed" start_time; Omake_build_util.print_failed_targets env buf; false end else true) in let () = if begin_success then (* Build the core *) if parallel || Omake_options.opt_parallel options then begin (* Add commands to build the targets *) List.iter (build_target env print) targets; (* Build *) make env end else begin (* Make them in order *) List.iter (fun target -> build_target env print target; make env) targets end; in if summary then begin if not (process_summary () && begin_success && build_phase env build_success_target && process_summary ()) then ignore (build_phase env build_failure_target); print_summary env end with | Sys_error _ | Omake_value_type.ExitException _ | Omake_value_type.ExitParentException _ | Omake_value_type.OmakeException _ | Omake_value_type.UncaughtException _ | Omake_value_type.RaiseException _ | Unix.Unix_error _ | Omake_value_type.OmakeFatalErr _ | Omake_value_type.OmakeFatal _ | Sys.Break | Failure _ | Omake_value_type.Return _ as exn -> Lm_unix_util.with_file_fmt env.env_summary (fun buf -> Format.fprintf buf "%a@." Omake_exn_print.pp_print_exn exn); Omake_build_util.print_stats env (match exn with Sys.Break -> "stopped" | _ -> "failed") start_time; print_summary env ~unlink:false; if Omake_options.opt_poll options && restartable_exn exn then begin Lm_unix_util.try_unlink_file env.env_summary; let reason = notify_wait_omakefile env in raise (Restart reason) end else if options.osh then env.env_error_code <- Omake_state.exn_error_code else begin Omake_build_util.close env; save env; raise (BuildExit Omake_state.exn_error_code) end in (* Save database before exiting *) if save_flag then save env; (* Return error if that happened *) if env.env_error_code <> 0 then build_on_error env save_flag start_time parallel print targets options env.env_error_code else if not (Omake_build_util.command_list_is_empty env CommandBlockedTag) then build_on_error env save_flag start_time parallel print targets options Omake_state.deadlock_error_code else if not (Omake_build_util.command_list_is_empty env CommandScanBlockedTag) then build_on_error env save_flag start_time parallel print targets options Omake_state.deadlock_error_code else if not (Omake_build_util.command_list_is_empty env CommandFailedTag) then build_on_error env save_flag start_time parallel print targets options Omake_state.deadlock_error_code and build_on_error env save_flag _ parallel print targets options error_code = if not (Omake_options.opt_poll options) then raise (BuildExit error_code) else begin notify_wait env; build_targets env save_flag (Unix.gettimeofday ()) parallel print targets end (* * Notification loop. *) let rec notify_loop env (options : Omake_options.t) targets = begin try notify_wait env with Sys.Break -> Format.eprintf "*** omake: Received Break signal, exiting@."; raise (BuildExit 0) end; (* Build the targets again *) let start_time = Unix.gettimeofday () in build_targets env true start_time false options.print_dependencies targets; Omake_build_util.print_stats env "done" start_time; notify_loop env options targets (** Start the core build. *) let build_core (env : Omake_build_type.t) dir start_time (options : Omake_options.t) targets = (* First, build all the included files *) let changed = if options.dry_run then false else let includes = Omake_node.NodeTable.fold (fun includes node _ -> node :: includes) [] env.env_includes in let _ = build_targets env false start_time true false ~summary:false includes in Omake_node.NodeTable.exists (fun node digest -> let digest' = Omake_cache.force_stat env.env_cache node in digest' <> digest) env.env_includes in let () = if changed then begin env.env_includes <- Omake_cache.stat_table env.env_cache env.env_includes; raise (Restart None) end in let venv : Omake_env.t = env.env_venv in let venv = Omake_env.venv_chdir_tmp venv dir in let targets = List.map (Omake_env.venv_intern venv PhonyOK) targets in let () = List.iter (fun s -> print_node_dependencies env (Omake_env.venv_intern venv PhonyOK s)) options.show_dependencies in let options = env_options env in build_targets env true start_time false options.print_dependencies targets; Omake_build_util.print_stats env "done" start_time; (* Polling loop *) if Omake_options.opt_poll_on_done options then if not Lm_notify.enabled then Format.eprintf "*** omake: Polling is not enabled@." else notify_loop env options targets; Omake_build_util.close env (** Main builder. *) let rec build_time start_time venv_opt (options : Omake_options.t) dir_name targets = let env : Omake_build_type.t = load venv_opt options targets in let dir_name = if options.project then "." else dir_name in let dir = Omake_node.Dir.chdir env.env_cwd dir_name in (* Monitor the full tree if polling *) let () = if Omake_options.opt_poll options then try Omake_exec.Exec.monitor_tree env.env_exec env.env_cwd with Failure _ -> (* This is just an optimization anyway *) () in (* * Check that this directory is actually a .SUBDIR. * Don't do the check in osh mode; we assume the script knows * what it is doing. *) let () = if venv_opt = None && not ( options.project || Omake_node.DirTable.mem env.env_explicit_directories dir) then begin Format.eprintf "*** omake: the current directory %s@." (Omake_node.Dir.absname dir); Format.eprintf "*** omake: is not part of the root project in %s@." (Omake_node.Dir.absname env.env_cwd); raise (BuildExit 1) end in let restart reason = print_restart options reason; Omake_build_util.close env; save env; build_time start_time venv_opt options dir_name targets in try build_core env dir start_time options targets with | Restart reason -> restart reason | Sys.Break as exn -> Omake_build_util.close env; save env; Format.eprintf "%a@." Omake_exn_print.pp_print_exn exn; raise (BuildExit Omake_state.exn_error_code) | exn when Omake_options.opt_poll options && restartable_exn exn -> Format.eprintf "%a@." Omake_exn_print.pp_print_exn exn; let reason = notify_wait_omakefile env in restart reason let build options dir_name targets = try Omake_shell_sys.set_interactive false; Omake_build_util.wait_for_lock (); build_time (Unix.gettimeofday ()) None options dir_name targets with BuildExit code -> Pervasives.exit code let build_fun venv targets = let options = Omake_env.venv_options venv in let dir = Omake_node.Dir.absname (Omake_env.venv_dir venv) in Unix.chdir dir; Omake_node.Dir.reset_cwd (); try Omake_build_util.wait_for_lock (); build_time (Unix.gettimeofday ()) (Some venv) options "." targets; true with BuildExit _ -> false omake-0.10.3/src/build/omake_target.ml0000644000175000017500000002102013177364665016212 0ustar gerdgerd(* Utilities on targets. *) include Omake_pos.Make (struct let name = "Omake_target" end) (* Target exists or is phony. *) let target_exists_or_is_phony cache target = Omake_cache.exists cache target || Omake_node.Node.is_phony target (* Target is part of an explicit rule. *) let target_is_explicit _ venv target = Omake_env.venv_explicit_exists venv target (* Target exists, is phony, or there is an explicit rule to build it. *) let target_exists_or_is_phony_or_is_explicit cache venv target = if Lm_debug.debug Omake_env.debug_implicit then Format.eprintf "target_exists_or_is_phony_or_is_explicit: %a: %b, %b@." (**) Omake_node.pp_print_node target (target_exists_or_is_phony cache target) (Omake_env.venv_explicit_exists venv target); target_exists_or_is_phony cache target || Omake_env.venv_explicit_exists venv target let icnt_limit = 3 (* * A target is buildable if it exists, or * if there is an implicit rule whose dependencies * are all buildable. *) let rec target_is_buildable_bound bound bound_l icnt cache venv pos target = let target = Omake_node.Node.unsquash target in (* Check for loops *) let bound = if icnt >= icnt_limit then List.fold_left Omake_node.NodeSet.add bound bound_l else bound in if icnt >= icnt_limit && Omake_node.NodeSet.mem bound target then raise (Omake_value_type.OmakeException(pos, StringNodeError("Cyclic implicit dependencies detected", target))); (target_exists_or_is_phony_or_is_explicit cache venv target || venv_find_buildable_implicit_rule_bound bound (target::bound_l) (icnt+1) cache venv pos target <> None) (* Find an applicable implicit rule with buildable sources *) and venv_find_buildable_implicit_rule_bound bound bound_l icnt cache venv pos target = let irules = Omake_env.venv_find_implicit_rules venv target in if Lm_debug.debug Omake_env.debug_implicit then Format.eprintf "venv_find_buildable_implicit_rule %a %a: %d commands to consider@." (**) Omake_node.pp_print_dir (Omake_env.venv_dir venv) Omake_node.pp_print_node target (List.length irules); search_irules bound bound_l icnt cache venv pos target irules and search_irules bound bound_l icnt cache venv pos target irules = match irules with irule :: irules -> let sources = irule.rule_sources in if Lm_debug.debug Omake_env.debug_implicit then Format.eprintf "@[venv_find_buildable_implicit_rule: considering implicit rule %a:%a@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set sources; if Omake_node.NodeSet.for_all (target_is_buildable_bound bound bound_l icnt cache venv (loc_pos irule.rule_loc pos)) sources then let irule' = Omake_rule.expand_rule irule in if irule == irule' || Omake_node.NodeSet.for_all (target_is_buildable_bound bound bound_l icnt cache venv pos) (Omake_node.NodeSet.diff irule'.rule_sources sources) then begin if Lm_debug.debug Omake_env.debug_implicit then Format.eprintf "@[venv_find_buildable_implicit_rule: accepted implicit rule %a:%a@]@." (**) Omake_node.pp_print_node target Omake_node.pp_print_node_set irule'.rule_sources; Some irule' end else search_irules bound bound_l icnt cache venv pos target irules else search_irules bound bound_l icnt cache venv pos target irules | [] -> None (* * Outer wrappers. *) (* let check_build_phase pos = *) (* if not (Omake_builtin_util.is_build_phase ()) then *) (* raise (Omake_value_type.OmakeException (pos, StringError "this command can only be executed in a rule body")) *) (* XXX: JYH: temporarily disable it *) let check_build_phase _pos = () let venv_find_buildable_implicit_rule cache venv pos target = check_build_phase pos; venv_find_buildable_implicit_rule_bound Omake_node.NodeSet.empty [] 0 cache venv pos target let target_is_buildable cache venv pos target = check_build_phase pos; let target = Omake_node.Node.unsquash target in let target_dir = Omake_node.Node.dir target in let target_file = Omake_node.Node.tail target in let node_kind = Omake_node.Node.kind target in let tdir = Omake_env.venv_lookup_target_dir venv target_dir in try Omake_env.venv_find_target_is_buildable_exn venv tdir target_file node_kind with | Not_found -> let flag = target_is_buildable_bound Omake_node.NodeSet.empty [] 0 cache venv pos target in Omake_env.venv_add_target_is_buildable venv tdir target_file node_kind flag; flag let target_is_buildable_in_path_1 cache venv pos path names = (* all [names] are seen as equivalent, and are searched simultaneously. e.g. use this for searching for the capitalized and uncapitalized versions of an ocaml file name *) (* NB. The target cache ignores now the phony-ness of targets, so it is ok to always look up for NodeNormal *) if names = [] then invalid_arg "Omake_target.target_is_buildable_in_path"; check_build_phase pos; let names = Array.of_list names in let pnames = Array.map Omake_node.parse_phony_name names in let encache_neg = Array.map (fun _ -> ref []) names in let lookup_in_target_cache = Array.map (fun name -> (* NB. This call can be evaluated, returning another function *) Omake_env.venv_find_target_is_buildable_multi venv name Omake_node_sig.NodeNormal ) names in let rec search path = match path with | (dir,tdir) :: path' -> let rec check_name i = if i < Array.length names then let pname = pnames.(i) in try let found = lookup_in_target_cache.(i) tdir in if found then ( let target = Omake_env.venv_intern_cd_1 venv PhonyOK dir pname in Some(dir, tdir, i, target) ) else (* This is the fast path of the algorithm *) check_name (i+1) with | Not_found -> let target = Omake_env.venv_intern_cd_1 venv PhonyOK dir pname in let ok = target_is_buildable_bound Omake_node.NodeSet.empty [] 0 cache venv pos target in if ok then Some(dir, tdir, i, target) else ( encache_neg.(i) := tdir :: !(encache_neg.(i)); check_name (i+1) ) else search path' in check_name 0 | _ -> None in let result = search path in match result with | Some(_dir, tdir, i, target) -> Array.iteri (fun j encache -> let pos_set = if i=j then [tdir] else [] in let neg_set = !encache in let node_kind = Omake_node_sig.NodeNormal in Omake_env.venv_add_target_is_buildable_multi venv names.(j) node_kind pos_set neg_set; ) encache_neg; Some target | None -> None let target_is_buildable_in_path cache venv pos path names = let path' = List.map (fun dir -> dir, Omake_env.venv_lookup_target_dir venv dir) path in target_is_buildable_in_path_1 cache venv pos path' names let target_is_buildable_proper cache venv pos target = let target = Omake_node.Node.unsquash target in let target_dir = Omake_node.Node.dir target in let target_file = Omake_node.Node.tail target in let node_kind = Omake_node.Node.kind target in let tdir = Omake_env.venv_lookup_target_dir venv target_dir in check_build_phase pos; try Omake_env.venv_find_target_is_buildable_proper_exn venv tdir target_file node_kind with Not_found -> let flag = if target_is_explicit cache venv target then true else venv_find_buildable_implicit_rule cache venv pos target <> None in Omake_env.venv_add_target_is_buildable_proper venv tdir target_file node_kind flag; flag omake-0.10.3/src/build/omake_builtin_type.ml0000644000175000017500000000220513177364666017440 0ustar gerdgerdtype builtin_fun = Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_value_type.t list -> Omake_value_type.t type builtin_kfun = Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_value_type.t list -> Omake_value_type.keyword_value list -> Omake_env.t * Omake_value_type.t type builtin_env_fun = Omake_build_type.t -> builtin_fun type builtin_object_info = string * Omake_ir.var * Omake_value_type.t type builtin_rule = bool * string list * string list type builtin_info = { builtin_vars : (string * (Omake_env.t -> Omake_value_type.t)) list; builtin_funs : (bool * string * builtin_fun * Omake_ir.arity) list; builtin_kfuns : (bool * string * builtin_kfun * Omake_ir.arity) list; builtin_objects : builtin_object_info list; pervasives_objects : string list; phony_targets : string list; builtin_rules : builtin_rule list } let builtin_empty = { builtin_vars = []; builtin_funs = []; builtin_kfuns = []; builtin_objects = []; pervasives_objects = []; phony_targets = []; builtin_rules = [] } omake-0.10.3/src/build/omake_build_type.ml0000644000175000017500000001723113177364666017076 0ustar gerdgerd (* * Magic number for marshaling. *) let magic_number = "" (** A command corresponds to a rule, where all variables have been resolved. A command can be in several states: Idle: the command is not currently used Initial: the command needs to be processed ScanBlocked: the command can't be scanned until the scanner dependencies have been built ScannedPending: the scanner dependencies have been satisfied, but the scan is blocked because the effects of this command have not been scanned yet. Scanned: the command has been scanned, and all effects have been scanned too Blocked: the command can't be run until all of its dependencies are built Ready: all dependencies have been satisfied, and the command is ready to run Pending: command is ready to run, but it conflicts with another job that is Running, so it has to wait Running (pid, file): the command is running, with the given pid. If this is a scanner, the output is being saved in the file Succeeded deps: the command succeeded. If this is a scanner the deps are a table of the dependencies. Failed code: the command failed with the given non-zero exit code. As a command is processed, it passes through each of these states in the given order, with the following exceptions: - The CommandScannedPending may be skipped - Only one of the Succeeded or Failed states is assigned *) type command_state = | CommandIdle | CommandInitial | CommandScanBlocked | CommandScannedPending | CommandScanned | CommandBlocked | CommandReady | CommandPending | CommandRunning of Omake_exec_id.t * scanner_detail option | CommandSucceeded of Omake_node.NodeSet.t Omake_node.NodeTable.t | CommandFailed of int and scanner_detail = { scanner_out_file : string; scanner_post_action : (Lm_location.t * scanner_post_action) option; } and scanner_post_action = (Omake_value_type.t, Omake_command_type.arg, Omake_env.apply) Omake_shell_type.poly_apply type command_tag = | CommandIdleTag | CommandInitialTag | CommandScanBlockedTag | CommandScannedPendingTag | CommandScannedTag | CommandBlockedTag | CommandReadyTag | CommandPendingTag | CommandRunningTag | CommandSucceededTag | CommandFailedTag (* * Commands for a rule. * * Invariant: CommandInfo and CommandLines must have * at least one command. * * CommandLines is CommandInfo after evaluation. * CommandScanner saves the commands so they may be re-evaluated after the scan. *) type command_body = CommandNone | CommandInfo of Omake_env.command_info list | CommandLines of Omake_env.command_info list * Omake_env.arg_command_line list * Omake_command_type.command_digest | CommandScanner of Omake_env.command_info list * Omake_node.NodeSet.t * Omake_env.arg_command_line list * Omake_command_type.command_digest (* * The command. * There is a 1-to-1 correspondence between commands and targets. * * command_state: the current command state * * command_target: the target node to be built * command_effects: the nodes that may be modified by this command * command_loc: the location of the rule being used to build * the target. * command_lines: the commands that should be run sequentially * to build the target. * * command_static_deps: the dependencies statically defined * in the OMakefiles. * command_scanner_deps: the :scanner: dependencies for a command * * command_build_deps: the dependencies, including implicit * dependencies produced by the scanner * command_blocked: at least one of the deps in the set * is blocked *) type command = { command_venv : Omake_env.t; mutable command_state : command_state; command_target : Omake_node.Node.t; mutable command_effects : Omake_node.NodeSet.t; command_locks : Omake_node.NodeSet.t; command_loc : Lm_location.t; (* Scanners for this command *) command_scanner_deps : Omake_node.NodeSet.t; (* Static deps from the OMakefiles *) command_static_deps : Omake_node.NodeSet.t; (* Actual dynamic dependencies *) mutable command_build_deps : Omake_node.NodeSet.t; mutable command_blocked : Omake_node.Node.t list; mutable command_lines : command_body; (* Output tees *) mutable command_tee : Omake_exec_util.tee; (* Linked list *) mutable command_pred : command option ref; command_succ : command option ref } (* * The environment remembers all the commands. In addition * we compute an inverted command graph , so that we know what to do * when a command finishes. * * env_venv: the default environment * env_cache: the build cache, so we don't run commands * if the target is already up-to-date. * env_explicit_deps: gives explicitly-defined dependencies of nodes * env_explicit_targets: maps nodes to rules where the node is a target * env_explicit_directories: maps directories to environments * * env_commands: all the commands * env_inverse: the inverted dependency graph * env_error_code: the exit code when an error occurs * env_idle_count: number of idle processors *) type env_wl = { env_idle_wl : command option ref; env_initial_wl : command option ref; env_scan_blocked_wl : command option ref; env_scanned_pending_wl : command option ref; env_scanned_wl : command option ref; env_blocked_wl : command option ref; env_ready_wl : command option ref; env_pending_wl : command option ref; env_running_wl : command option ref; env_succeeded_wl : command option ref; env_failed_wl : command option ref } type t = { env_venv : Omake_env.t; env_cwd : Omake_node.Dir.t; env_cache : Omake_cache.t; env_exec : Omake_env.exec; mutable env_explicit_deps : (Omake_node.NodeSet.t * Omake_node.NodeSet.t * Omake_node.NodeSet.t) Omake_node.NodeTable.t; env_explicit_targets : Omake_env.erule Omake_node.NodeTable.t; env_explicit_directories : Omake_env.t Omake_node.DirTable.t; mutable env_includes : Omake_cache_type.digest Omake_node.NodeTable.t; (* Build state *) mutable env_commands : command Omake_node.NodeTable.t; mutable env_inverse : command Omake_node.NodeTable.t Omake_node.NodeTable.t; mutable env_error_code : int; mutable env_idle_count : int; mutable env_print_dependencies : Omake_node.NodeSet.t; (* Worklists *) mutable env_current_wl : env_wl; env_main_wl : env_wl; (* Pending events *) mutable env_pending_events : Lm_notify.event Queue.t; (* Output files *) env_summary : string; (* Statistics *) mutable env_succeeded_count : int; mutable env_optional_count : int; mutable env_scan_count : int; mutable env_scan_exec_count : int; mutable env_rule_count : int; mutable env_rule_exec_count : int } (* * Helper type for determining how to build a command * from a rule. *) type explicit_rule = | ExplicitTarget of Omake_env.erule | ExplicitDirectory of Omake_env.t | ExplicitNone omake-0.10.3/src/build/omake_build_util.ml0000644000175000017500000007241513177364666017077 0ustar gerdgerd module Pos = Omake_pos.Make (struct let name = "Omake_build_util" end) (* * Check whether a node is a leaf node. *) let is_leaf_command ({ command_scanner_deps = scanner_deps; command_static_deps = static_deps; command_build_deps = build_deps; command_lines = lines; _ } : Omake_build_type.command) = Omake_node.NodeSet.is_empty scanner_deps && Omake_node.NodeSet.is_empty static_deps && Omake_node.NodeSet.is_empty build_deps && (lines = CommandNone) let is_leaf_node (env : Omake_build_type.t) node = try is_leaf_command (Omake_node.NodeTable.find env.env_commands node) with Not_found -> false (* * Maintaining the environment. *) let saved_env = ref None let set_env env = saved_env := Some env let get_env pos loc = match !saved_env with | Some env -> env | None -> raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, StringError "this function can be called only in rule bodies")) let is_build_phase () = !saved_env <> None (* * Command-line definitions. *) let command_defs = ref [] let add_command_def v s = command_defs := (v, s) :: !command_defs let command_defs_are_nonempty () = !command_defs <> [] (************************************************************************ * Run-time variables. * * Strip the leading qualifiers. * This is a big hack, repeating Omake_ir_ast. * We may want to move this into there. *) let parse_path _ venv pos loc s = let vl = List.map Lm_symbol.add (Lm_string_util.split "." s) in match Omake_ir_ast.parse_declaration venv pos loc vl with | NameEmpty _ -> raise (Omake_value_type.OmakeException (pos, StringError "empty name")) | NameMethod (_, v, _ :: _) -> raise (Omake_value_type.OmakeException (pos, StringVarError ("name has too many components", v))) | NameMethod (info, v, vl) -> let info : Omake_ir.var_info = match info.name_scope with | Some VarScopePrivate -> VarPrivate (loc, v) | Some VarScopeThis -> VarThis (loc, v) | Some VarScopeVirtual | None -> VarVirtual (loc, v) | Some VarScopeGlobal -> VarGlobal (loc, v) in info, vl let parse_sym = parse_path (fun loc v -> Omake_ir.VarThis (loc, v)) let parse_def venv pos loc s = let v, vl = parse_path (fun loc v -> Omake_ir.VarVirtual (loc, v)) venv pos loc s in if vl <> [] then raise (Omake_value_type.OmakeException (pos, StringError "name has too many components")); v let venv_add_command_defs venv = let loc = Lm_location.bogus_loc "" in let pos = Pos.string_pos "venv_add_command_defs" (Pos.loc_exp_pos loc) in List.fold_left (fun venv (v, s) -> let v = parse_def venv pos loc v in Omake_env.venv_add_var venv v (Omake_value_type.ValString s)) venv !command_defs (* * Extend an object with another. * The argument may be a file or an object. *) let object_of_file venv pos loc s : Omake_value_type.obj = let pos = Pos.string_pos "extends" pos in let node = Omake_eval.find_include_file venv pos loc s in try Omake_env.venv_find_object_file_exn venv node with Not_found -> let obj = Omake_eval.eval_object_file venv pos loc node in Omake_env.venv_add_object_file venv node obj; obj (* * This is a totally different sorting algorithm than that used in * revision 1.2. * * Here is the new assumption: only direct dependencies matter. * That is, the transitive closure is not needed for nodes outside * the set being sorted. * * This version uses a simple DFS to order the nodes. * * The numbers in IntNodeCompare are the sequence number of the node * in the input list. They are used to make the output order as similar * to the input one as possible (http://bugzilla.metaprl.org/show_bug.cgi?id=376) *) module IntNodeCompare = struct type t = int * Omake_node.Node.t let compare (i1, n1) (i2, n2) = match i1 - i2 with 0 -> Omake_node.Node.compare n1 n2 | i -> i end module IntNodeSet = Lm_set.LmMake (IntNodeCompare) module IntNodeTable = Lm_map.LmMake (IntNodeCompare) (* * Get the dependencies for this set of names. *) let command_deps venv orules domain deps = let deps = Omake_env.venv_get_ordering_deps venv orules deps in Omake_node.NodeSet.fold (fun deps dep -> if Omake_node.NodeTable.mem domain dep then IntNodeSet.add deps (Omake_node.NodeTable.find domain dep, dep) else deps) IntNodeSet.empty deps (* * Build the subgraph, including only those nodes that we actually * care about. *) let build_subgraph (env : Omake_build_type.t) venv pos orules domain = Omake_node.NodeTable.fold (fun graph node i -> try let command = Omake_node.NodeTable.find env.env_commands node in let deps = command_deps venv orules domain command.command_build_deps in let node = i, node in IntNodeTable.add graph node (IntNodeSet.remove deps node) with Not_found -> raise (Omake_value_type.OmakeException (pos, StringNodeError ("file is not found", node)))) IntNodeTable.empty domain let print_cycle wl (_, node) buf = let rec print = function [] -> raise (Invalid_argument "Omake_build_util: internal_error") | ((_, node'), _) :: wl -> if not (Omake_node.Node.equal node node') then print wl; Format.fprintf buf "%a@ > " Omake_node.pp_print_node node'; in Format.fprintf buf "@[Sort failed: found a cycle:@ "; print wl; Format.fprintf buf "%a@]" Omake_node.pp_print_node node (* * Produce a sort in DFS order. * * graph - the dependencies of the nodes not touched yet * marked - the nodes currently in the work list. "Touching" a marked node again means we found a loop. * items - the list constructed so far * in_list - the set of nodes in the items list * last argument - the "backtrace" (work list). *) let rec dfs_sort_aux pos graph marked items = function ((node, deps) :: bt) as all_bt -> if IntNodeSet.is_empty deps then (* Pop the work list *) dfs_sort_aux pos graph (IntNodeSet.remove marked node) (snd node :: items) bt else let node' = IntNodeSet.choose deps in if IntNodeSet.mem marked node' then raise (Omake_value_type.OmakeException (pos, LazyError (print_cycle all_bt node'))) else let bt = (node, IntNodeSet.remove deps node') :: bt in if IntNodeTable.mem graph node' then let deps = IntNodeTable.find graph node' in let graph = IntNodeTable.remove graph node' in let marked = IntNodeSet.add marked node' in dfs_sort_aux pos graph marked items ((node', deps) :: bt) else (* node' is already in the items list *) dfs_sort_aux pos graph marked items bt | [] -> if IntNodeTable.is_empty graph then (* We are done! *) List.rev items else (* Pick a starting point and start adding it to the output *) let node, deps = IntNodeTable.choose graph in let graph = IntNodeTable.remove graph node in let marked = IntNodeSet.singleton node in dfs_sort_aux pos graph marked items [node, deps] let dfs_sort pos graph _ = if IntNodeTable.is_empty graph then [] else dfs_sort_aux pos graph IntNodeSet.empty [] [] (* * Check that a list of nodes is in sorted order. *) let check_sort pos graph domain = Omake_node.NodeTable.iter (fun node index -> let deps = IntNodeTable.find graph (index, node) in IntNodeSet.iter (fun (index', dep) -> if index' > index then let print_problem buf = Format.fprintf buf "@[Nodes are out of order:@ Node %a@ Depends on %a@]" (**) Omake_node.pp_print_node node Omake_node.pp_print_node dep in raise (Omake_value_type.OmakeException (pos, LazyError print_problem))) deps) domain (* * The main sorting function. *) let sort_aux sorter env venv pos name nodes = let pos = Pos.string_pos "sort" pos in (* Get extra ordering info *) let oinfo = Omake_env.venv_get_ordering_info venv name in (* Produce a table of the listing order *) let domain, _ = List.fold_left (fun (domain, i) node -> let domain = Omake_node.NodeTable.add domain node i in let i = succ i in domain, i) (Omake_node.NodeTable.empty, 0) nodes in (* Build the graph *) let graph = build_subgraph env venv pos oinfo domain in sorter pos graph domain (* * Top-level functions. *) let check_sort = sort_aux check_sort let sort = sort_aux dfs_sort (* * Get the list pointer for a node class. *) let command_tag : Omake_build_type.command_state -> Omake_build_type.command_tag = function | CommandIdle -> CommandIdleTag | CommandInitial -> CommandInitialTag | CommandScanBlocked -> CommandScanBlockedTag | CommandScannedPending -> CommandScannedPendingTag | CommandScanned -> CommandScannedTag | CommandBlocked -> CommandBlockedTag | CommandReady -> CommandReadyTag | CommandPending -> CommandPendingTag | CommandRunning _ -> CommandRunningTag | CommandSucceeded _ -> CommandSucceededTag | CommandFailed _ -> CommandFailedTag let get_worklist_command (wl : Omake_build_type.env_wl) (x : Omake_build_type.command_tag) = match x with | CommandIdleTag -> wl.env_idle_wl | CommandInitialTag -> wl.env_initial_wl | CommandScanBlockedTag -> wl.env_scan_blocked_wl | CommandScannedPendingTag -> wl.env_scanned_pending_wl | CommandScannedTag -> wl.env_scanned_wl | CommandBlockedTag -> wl.env_blocked_wl | CommandReadyTag -> wl.env_ready_wl | CommandPendingTag -> wl.env_pending_wl | CommandRunningTag -> wl.env_running_wl | CommandSucceededTag -> wl.env_succeeded_wl | CommandFailedTag -> wl.env_failed_wl let command_worklist (env : Omake_build_type.t) state = get_worklist_command env.env_current_wl state (* * Worklist creation. *) let create_wl () : Omake_build_type.env_wl= { env_idle_wl = ref None; env_initial_wl = ref None; env_scan_blocked_wl = ref None; env_scanned_pending_wl = ref None; env_scanned_wl = ref None; env_blocked_wl = ref None; env_ready_wl = ref None; env_pending_wl = ref None; env_running_wl = ref None; env_succeeded_wl = ref None; env_failed_wl = ref None } (* * Check if a command succeeded. *) let command_succeeded (command : Omake_build_type.command) = match command with | { command_state = CommandSucceeded _; _ } -> true | _ -> false (* * Test for empty. *) let command_list_is_empty env state = let l = command_worklist env state in match !l with | Some _ -> false | None -> true (* * Get the head of a list. *) let command_list_head env state = let l = command_worklist env state in match !l with Some command -> command | None -> raise (Invalid_argument "command_list_head") (* * Iterate through the node list. *) let command_iter env state f = let rec iter (command_opt : Omake_build_type.command option) = match command_opt with | Some command -> let next = !(command.command_succ) in f command; iter next | None -> () in iter (!(command_worklist env state)) (* * Fold through the command list. *) let command_fold env state f x = let rec fold x (command : Omake_build_type.command option) = match command with | Some command -> let next = !(command.command_succ) in let x = f x command in fold x next | None -> x in let x = fold x (!(command_worklist env state)) in if env.env_main_wl == env.env_current_wl then x else fold x (!(get_worklist_command env.env_main_wl state)) (* * Existential test. *) let command_exists env state f x = let rec exists (command : Omake_build_type.command option) = match command with | Some command -> let next = !(command.command_succ) in f command || exists next | None -> x in exists (!(command_worklist env state)) (* * Find a particular command. *) let command_find env state f = let rec find (command : Omake_build_type.command option) = match command with | Some command -> if f command then command else find (!(command.command_succ)) | None -> raise Not_found in find (!(command_worklist env state)) (* * Test for empty. *) let command_list_is_empty env state = let l = command_worklist env state in match !l with | Some _ -> false | None -> true (* * Get the head of a list. *) let command_list_head env state = let l = command_worklist env state in match !l with Some command -> command | None -> raise (Invalid_argument "command_list_head") let pp_print_command_state buf (state : Omake_build_type.command_state) = match state with | CommandIdle -> Lm_printf.pp_print_string buf "idle" | CommandInitial -> Lm_printf.pp_print_string buf "initial" | CommandScanBlocked -> Lm_printf.pp_print_string buf "scan-blocked" | CommandScannedPending -> Lm_printf.pp_print_string buf "scanned-pending" | CommandScanned -> Lm_printf.pp_print_string buf "scanned" | CommandBlocked -> Lm_printf.pp_print_string buf "blocked" | CommandPending -> Lm_printf.pp_print_string buf "pending" | CommandReady -> Lm_printf.pp_print_string buf "ready" | CommandRunning (pid, None) -> Format.fprintf buf "running(%a)" Omake_exec_id.pp_print_pid pid | CommandRunning (pid, Some detail) -> Format.fprintf buf "scanning(%a, %s)" Omake_exec_id.pp_print_pid pid detail.scanner_out_file | CommandSucceeded _ -> Lm_printf.pp_print_string buf "succeeded" | CommandFailed code -> Format.fprintf buf "failed(%d)" code (* let pp_print_command_opt buf (command_opt : Omake_build_type.command option) = *) (* match command_opt with *) (* | Some { command_target = target; *) (* command_state = state; _} -> *) (* Format.fprintf buf "%a[%a]" Omake_node.pp_print_node target pp_print_command_state state *) (* | None -> *) (* Lm_printf.pp_print_string buf "" *) let pp_print_command buf (command : Omake_build_type.command) = match command with { command_target = target; command_effects = effects; command_locks = locks; command_state = state; command_scanner_deps = scanner_deps; command_build_deps = build_deps; command_blocked = blocked; _ } -> Format.fprintf buf "@[%a[%a],@ @[effects =%a@]@ @[locks =%a@]@ @[scanner deps =%a@]@ @[build deps =%a@]@ @[blocked =%a@]@]" (**) Omake_node.pp_print_node target pp_print_command_state state Omake_node.pp_print_node_set effects Omake_node.pp_print_node_set locks Omake_node.pp_print_node_set scanner_deps Omake_node.pp_print_node_set build_deps Omake_node.pp_print_node_list blocked let pp_print_node_states (env : Omake_build_type.t) buf nodes = Omake_node.NodeSet.iter (fun target -> try let command = Omake_node.NodeTable.find env.env_commands target(* find_command env target *) in Format.fprintf buf "@ %a(%a)" (**) Omake_node.pp_print_node target pp_print_command_state command.command_state with Not_found -> Omake_node.pp_print_node buf target) nodes let print_stats (env : Omake_build_type.t) message start_time = match env with { env_venv = venv; env_cache = cache; env_scan_count = scan_count; env_scan_exec_count = scan_exec_count; env_rule_count = rule_count; env_rule_exec_count = rule_exec_count; _ } -> let stat_count, digest_count = Omake_cache.stats cache in let total_time = Unix.gettimeofday () -. start_time in let options = Omake_env.venv_options venv in Omake_exec_print.print_leaving_current_directory options; if Omake_options.opt_print_status options then begin if message <> "done" then begin let total = Omake_node.NodeTable.cardinal env.env_commands - env.env_optional_count in Lm_printf.printf "*** omake: %i/%i targets are up to date@." env.env_succeeded_count total end; Lm_printf.printf "*** omake: %s (%a, %d/%d scans, %d/%d rules, %d/%d digests)@." (**) message Lm_unix_util.pp_time total_time scan_exec_count scan_count rule_exec_count rule_count digest_count stat_count end (* * All of the commands in the Blocked queue are deadlocked. *) let print_deadlock_exn env buf state = (* Inconsistency *) let failwith_inconsistency (command : Omake_build_type.command) = match command with { command_target = target; command_state = state; command_effects = effects; command_scanner_deps = scanner_deps; command_static_deps = static_deps; command_build_deps = build_deps; command_loc = loc; _ } -> Format.fprintf buf "@[*** omake: inconsistent state %a@ state = %a@ @[effects =%a@]@ @[build deps =%a@]@ @[scanner deps =%a@]@ @[static deps = %a@]@." (**) Omake_node.pp_print_node target pp_print_command_state state (pp_print_node_states env) effects (pp_print_node_states env) build_deps (pp_print_node_states env) scanner_deps (pp_print_node_states env) static_deps; raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, StringNodeError ("failed on target", target))) in (* Deadlock *) let failwith_deadlock loc target marked = let rec print_marked marked = match marked with mark :: marked -> Format.fprintf buf "*** omake: is a dependency of %a@." Omake_node.pp_print_node mark; if not (Omake_node.Node.equal mark target) then print_marked marked | [] -> Format.fprintf buf "*** omake: not deadlocked!@." in Format.fprintf buf "*** omake: deadlock on %a@." Omake_node.pp_print_node target; print_marked marked; raise (Omake_value_type.OmakeException (Pos.loc_exp_pos loc, StringNodeError ("failed on target", target))) in (* * Find the deadlock. *) let rec print marked (command : Omake_build_type.command) = match command with { command_target = target; command_loc = loc; _ } -> (* * Find the first dependency that has not been built. *) let rec search deps' = match deps' with dep :: deps -> let command = try let command = Omake_node.NodeTable.find env.env_commands dep (* find_command env dep *) in if command_succeeded command then None else Some command with Not_found -> Format.fprintf buf "*** omake: Do not know how to build \"%a\" required for \"%a\"@." Omake_node.pp_print_node dep Omake_node.pp_print_node target; raise (Failure "blocked") in (match command with Some dep -> dep | None -> search deps) | [] -> (* All deps have succeeded; this is an inconsistent state *) failwith_inconsistency command in (* Detect deadlock *) if List.exists (fun node -> Omake_node.Node.equal node target) marked then failwith_deadlock loc target marked; (* Otherwise, search for first unsatisfied dependency *) let deps = Omake_node.NodeSet.union (**) (Omake_node.NodeSet.union command.command_build_deps command.command_scanner_deps) command.command_static_deps in print (target :: marked) (search (Omake_node.NodeSet.to_list deps)) in print [] (command_list_head env state) let print_deadlock env buf state = try print_deadlock_exn env buf state with Omake_value_type.OmakeException _ | Failure _ as exn -> Format.fprintf buf "%a@." Omake_exn_print.pp_print_exn exn (* * Print the failed commands. *) let print_failed_targets (env : Omake_build_type.t) buf = if Omake_options.opt_print_status (Omake_env.venv_options env.env_venv) then begin Format.fprintf buf "*** omake: targets were not rebuilt because of errors:"; (* We use table to get an alphabetical order here - see http://bugzilla.metaprl.org/show_bug.cgi?id=621 *) let table = ref Lm_string_set.LexStringMTable.empty in let add_command (command : Omake_build_type.command) = table := Lm_string_set.LexStringMTable.add !table (Omake_node.Node.absname command.command_target) command in let () = command_iter env CommandFailedTag add_command in Lm_string_set.LexStringMTable.iter (fun _ (command : Omake_build_type.command) -> Format.fprintf buf "@\n @[@[%a" Omake_node.pp_print_node command.command_target; Omake_node.NodeSet.iter (fun dep -> if Omake_node.Node.is_real dep && is_leaf_node env dep then Format.fprintf buf "@ depends on: %a" Omake_node.pp_print_node dep) command.command_static_deps; Format.fprintf buf "@]"; Omake_build_tee.format_tee_with_nl buf command; Format.fprintf buf "@]") !table; Format.fprintf buf "@." end let print_failed env buf state = if not (command_list_is_empty env CommandFailedTag) then print_failed_targets env buf else print_deadlock env buf state let eprint_env env = begin Format.eprintf "@[Initial:"; command_iter env CommandInitialTag (fun command -> Format.eprintf "@ %a" pp_print_command command); Format.eprintf "@]@."; Format.eprintf "@[ScanBlocked:"; command_iter env CommandScanBlockedTag (fun command -> Format.eprintf "@ %a" pp_print_command command); Format.eprintf "@]@."; Format.eprintf "@[Blocked:"; command_iter env CommandBlockedTag (fun command -> Format.eprintf "@ %a" pp_print_command command); Format.eprintf "@]@."; Format.eprintf "@[Ready:"; command_iter env CommandReadyTag (fun command -> Format.eprintf "@ %a" pp_print_command command); Format.eprintf "@]@."; Format.eprintf "@[Running:"; command_iter env CommandRunningTag (fun command -> Format.eprintf "@ %a" pp_print_command command); Format.eprintf "@]@."; Format.eprintf "@[Succeeded:"; command_iter env CommandSucceededTag (fun command -> Format.eprintf "@ %a" pp_print_command command); Format.eprintf "@]@."; Format.eprintf "@[Failed:"; command_iter env CommandFailedTag (fun command -> Format.eprintf "@ %a" pp_print_command command); Format.eprintf "@]@."; end (** [TODO] Take a lock to prevent multiple builds from competing. *) let copy_to_stderr fd = let inx = Unix.in_channel_of_descr fd in let rec loop () = let line = input_line inx in Format.eprintf "%s@." line; loop () in try loop () with End_of_file -> () let wait_for_lock, unlock_db = let name = Omake_state.db_name ^ ".lock" in let save_fd = ref None in let unlock_db () = match !save_fd with | None -> () | Some fd -> let () = (* XXX: JYH: this is bad style. * Under what circumstances will this fail? * BTW, don't use wildcard exception patterns please:/ *) try Omake_shell_sys.close_fd fd with Unix.Unix_error _ -> () in save_fd := None in let wait_for_lock () = unlock_db (); let fd = try Lm_unix_util.openfile name [O_RDWR; O_CREAT] 0o666 with Unix.Unix_error _ -> raise (Failure ("project lock file is not writable: " ^ name)) in let () = (* * XXX: TODO: We use lockf, but it is not NFS-safe if filesystem is mounted w/o locking. * .omakedb locking is only convenience, not safety, so it's not a huge problem. * But may be we should implement a "sloppy" locking as well - see * also the mailing list discussions: * - http://lists.metaprl.org/pipermail/omake/2005-November/thread.html#744 * - http://lists.metaprl.org/pipermail/omake-devel/2005-November/thread.html#122 *) try (* Try for a lock first, and report it if the file is locked *) try Lm_unix_util.lockf fd Unix.F_TLOCK 0 with Unix.Unix_error (Unix.EAGAIN, _, _) -> Format.eprintf "*** omake: the project is currently locked.@."; (try copy_to_stderr fd with _ -> ()); (* Unfortunately, we have to poll, since OCaml doesn't allow ^C during the lock request *) let rec poll col = let col = if col >= 40 then begin if col = 40 then Format.eprintf "@."; Format.eprintf "*** omake: waiting for project lock: .@?"; 0 end else begin Format.eprintf ".@?"; succ col end in Unix.sleep 1; try Lm_unix_util.lockf fd Unix.F_TLOCK 0 with Unix.Unix_error (Unix.EAGAIN, _, _) -> poll col in poll 1000 with (* * XXX: When lockf is not supported, we just print a warning and keep going. * .omakedb locking is only convenience, not safety, so it's not a huge problem. *) Unix.Unix_error ((Unix.EOPNOTSUPP | Unix.ENOLCK) as err, _, _) -> Format.eprintf "*** omake WARNING: Can not lock the project database file .omakedb:\ \t%s. Will proceed anyway.\ \tWARNING: Be aware that simultaneously running more than one instance\ \t\tof OMake on the same project is not recommended. It may\ \t\tresult in some OMake instances failing to record their\ \t\tprogress in the database@." (Unix.error_message err) | Unix.Unix_error (err, _, _) -> raise (Failure ("Failed to lock the file " ^ name ^ ": " ^ (Unix.error_message err))) | Failure err -> raise (Failure ("Failed to lock the file " ^ name ^ ": " ^ err)) in Omake_shell_sys.set_close_on_exec fd; save_fd := Some fd; (* Print the message to the lock file *) try ignore (Unix.lseek fd 0 Unix.SEEK_SET); Lm_unix_util.ftruncate fd; let outx = Unix.out_channel_of_descr fd in Printf.fprintf outx "*** omake: the project was last locked by %s:%d.\n" (Unix.gethostname ()) (Unix.getpid ()); Pervasives.flush outx with Unix.Unix_error _ | Sys_error _ | Failure _ -> () in wait_for_lock, unlock_db (* * Catch the dependency printer. *) let close (env : Omake_build_type.t) = Omake_node.NodeTable.iter (fun _ command -> Omake_build_tee.unlink_tee command) env.env_commands; Omake_exec.Exec.close env.env_exec; Lm_unix_util.try_unlink_file env.env_summary (* let env_options (env : Omake_build_type.t) = Omake_env.venv_options env.env_venv let pid = Unix.getpid () (* this is the PID of the main thread *) (* * Save the cache and environment to a file. *) let save_aux (env : Omake_build_type.t) = (* Only the "master" thread should be saving the DB *) if (pid <> Unix.getpid ()) then begin Format.eprintf "@[*** OMake Internal ERROR:@ Slave thread %i trying to save db opened by the master thread %i@]@." (Unix.getpid ()) pid; raise (Invalid_argument "Internal error: Slave thread trying to save the OMake DB") end; (* Save the static values *) let () = Omake_env.venv_save_static_values env.env_venv in (* Save the .omakedb *) let cache = env.env_cache in (* We want the name to be fairly unique in case locking had failed us. *) let db_tmp = Lm_printf.sprintf ".#%s.%s.%i" Omake_state.db_name (Unix.gethostname ()) pid in (* Marshal the state to the output file *) let outx = Pervasives.open_out_bin db_tmp in let includes = Omake_node.NodeTable.fold (fun includes node _ -> Omake_node.NodeSet.add includes node) Omake_node.NodeSet.empty env.env_includes in let targets = Omake_node.NodeSet.singleton Omake_cache.env_target in try Omake_cache.add cache Omake_cache.env_fun Omake_cache.env_target targets includes None (MemoSuccess Omake_node.NodeTable.empty); Omake_cache.to_channel outx cache; close_out outx; Unix.rename db_tmp Omake_state.db_name with Unix.Unix_error (errno, name, arg) -> Format.eprintf "*** omake: failure during saving: %s: %s(%s)@." (Unix.error_message errno) name arg; close_out outx; unlink_file db_tmp | Sys_error _ | Failure _ as exn -> Format.eprintf "*** omake: failure during saving: %s@." (Printexc.to_string exn); close_out outx; unlink_file db_tmp (* * Save to the .omakedb. *) let save env = if not (env_options env).dry_run then try save_aux env with Sys_error _ as exn -> Format.eprintf "*** omake: failure during saving: %s@." (Printexc.to_string exn) *) omake-0.10.3/src/build/omake_builtin.ml0000644000175000017500000001344613177364666016410 0ustar gerdgerd include Omake_pos.Make (struct let name = "Omake_builtin" end) (* let object_sym = Lm_symbol.add "Object" *) (* * Add a command line variable definition. *) let add_command_def = Omake_build_util.add_command_def let command_defs_are_nonempty = Omake_build_util.command_defs_are_nonempty let venv_add_command_defs = Omake_build_util.venv_add_command_defs (* * Register some builtin info. *) let builtin_info = ref Omake_builtin_type.builtin_empty let register_builtin info = let { Omake_builtin_type.builtin_vars = builtin_vars1; builtin_funs = builtin_funs1; builtin_kfuns = builtin_kfuns1; builtin_objects = builtin_objects1; pervasives_objects = pervasives_objects1; phony_targets = phony_targets1; builtin_rules = builtin_rules1 } = !builtin_info in let { Omake_builtin_type.builtin_vars = builtin_vars2; builtin_funs = builtin_funs2; builtin_kfuns = builtin_kfuns2; builtin_objects = builtin_objects2; pervasives_objects = pervasives_objects2; phony_targets = phony_targets2; builtin_rules = builtin_rules2 } = info in let info = { Omake_builtin_type.builtin_vars = builtin_vars1 @ builtin_vars2; builtin_funs = builtin_funs1 @ builtin_funs2; builtin_kfuns = builtin_kfuns1 @ builtin_kfuns2; builtin_objects = builtin_objects1 @ builtin_objects2; pervasives_objects = pervasives_objects1 @ pervasives_objects2; phony_targets = phony_targets1 @ phony_targets2; builtin_rules = builtin_rules1 @ builtin_rules2 } in builtin_info := info let get_registered_builtins () = !builtin_info (* * Check that there are no keyword arguments. *) let wrap_normal_prim_fun f venv pos loc args kargs = match kargs with [] -> venv, f venv pos loc args | (v, _) :: _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("no such parameter", v))) (* * Add all the functions to the environment. *) let venv_add_builtins venv = let loc = Lm_location.bogus_loc "" in let pos = string_pos "venv_add_builtins" (loc_exp_pos loc) in match get_registered_builtins () with { builtin_vars ; builtin_funs ; builtin_kfuns ; builtin_objects ; pervasives_objects ; phony_targets ; builtin_rules } -> (* Add only to the protected (current object) environment *) let venv = Omake_env.venv_add_phony venv loc (List.map (fun s -> Omake_value_type.TargetString s) phony_targets) in let venv = List.fold_left (fun venv (special, s, f, arity) -> let name = Lm_symbol.add s in let (v : Omake_ir.var_info) = VarGlobal (loc, name) in let p = Omake_env.venv_add_prim_fun venv name (wrap_normal_prim_fun f) in let no_args = match (arity : Omake_ir.arity) with | ArityExact 0 -> Omake_ir.ApplyEmpty | _ -> ApplyNonEmpty in Omake_env.venv_add_var venv v (ValPrim (arity, special,no_args, p))) venv builtin_funs in let venv = List.fold_left (fun venv (special, s, f, arity) -> let name = Lm_symbol.add s in let (v : Omake_ir.var_info) = VarGlobal (loc, name) in let p = Omake_env.venv_add_prim_fun venv name f in let (no_args : Omake_ir.apply_empty_strategy) = match (arity : Omake_ir.arity) with | ArityExact 0 -> ApplyEmpty | _ -> ApplyNonEmpty in Omake_env.venv_add_var venv v (ValPrim (arity, special,no_args, p))) venv builtin_kfuns in let venv = List.fold_left (fun venv (multiple, targets, sources) -> let targets = List.map (fun name -> Omake_value_type.TargetString name) targets in let sources = List.map (fun source -> Omake_node_sig.NodeNormal, Omake_value_type.TargetString source) sources in let multiple : Omake_value_type.rule_multiple = if multiple then RuleMultiple else RuleSingle in let venv, _ = Omake_env.venv_add_rule venv pos loc multiple targets [] [] sources [] [] [] in venv) venv builtin_rules in (* Add the Object object *) let obj = Omake_env.venv_empty_object in (* Add values to each of the primitive objects *) let venv = List.fold_left (fun venv (s, v, x) -> let obj = Omake_env.venv_add_field_internal obj v x in Omake_env.venv_add_var venv (VarGlobal (loc, Lm_symbol.add s)) (ValObject obj)) venv builtin_objects in let venv = List.fold_left (fun venv s -> Omake_env.venv_add_var venv (VarGlobal (loc, Lm_symbol.add s)) (ValObject obj)) venv pervasives_objects in (* Add the variables last *) let venv = List.fold_left (fun venv (s, v) -> Omake_env.venv_add_var venv (VarGlobal (loc, Lm_symbol.add s)) (v venv)) venv builtin_vars in venv (* * Add the Pervasives module. *) let venv_add_pervasives venv = let loc = Lm_location.bogus_loc "Omake_builtin" in let pos = string_pos "venv_add_pervasives" (loc_exp_pos loc) in let () = Omake_env.venv_set_pervasives venv in let obj = Omake_build_util.object_of_file venv pos loc "Pervasives" in let venv = Omake_env.venv_flatten_object venv obj in Omake_env.venv_set_pervasives venv; venv (* * Load a file. *) let venv_include_rc_file venv name = if Sys.file_exists name then let node = Omake_env.venv_intern venv PhonyProhibited name in try let loc = Lm_location.bogus_loc (Filename.basename name) in let pos = string_pos "create_venv" (loc_exp_pos loc) in Omake_eval.include_file venv IncludePervasives pos loc node with exn -> Format.eprintf "%a@." Omake_exn_print.pp_print_exn exn; venv else venv (*! * @docoff * * -*- * Local Variables: * Caml-master: "compile" * End: * -*- *) omake-0.10.3/src/build/omake_rule.mli0000644000175000017500000000512613177364666016056 0ustar gerdgerd(* * Rule expansion. *) (* Debugging. *) val debug_active_rules : bool ref (* * Expand rules so that the rule body is not a function. *) val expand_rule : Omake_env.erule -> Omake_env.erule (* * Glob options. *) val glob_options_of_string : Lm_glob.glob_option list -> string -> Lm_glob.glob_option list val glob_options_of_env : Omake_env.t -> Omake_value_type.pos -> Lm_glob.glob_option list val normalize_apply : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Lm_glob.glob_options -> (Omake_value_type.t, Omake_command_type.arg, Omake_env.apply) Omake_shell_type.poly_apply -> (Omake_value_type.t, string, Omake_env.apply) Omake_shell_type.poly_apply (* * Evaluators for the Exec module. *) val eval_shell : Omake_env.t -> Omake_value_type.pos -> (Omake_env.arg_command_line, Omake_env.pid, Omake_value_type.t) Omake_exec_type.shell (* * Create the command lines. * eval_commands venv loc target sloppy_deps commands * * The sloppy deps are used for scanner commands to represent the * results of the previous scan. *) val eval_commands : Omake_env.t -> Lm_location.t -> Omake_node.Node.t -> Omake_node.NodeSet.t -> Omake_env.command_info list -> Omake_env.arg_command_line list (* * Rules and shell expressions. *) val eval_rule_exp : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> bool -> (* multiple (whether the rule was defined with a ::) *) Omake_value_type.t -> (* targets *) Omake_value_type.t -> (* patterns *) Omake_value_type.t -> (* sources *) Omake_value_type.t -> (* options *) Omake_value_type.t -> (* commands *) Omake_env.t * Omake_value_type.t val eval_memo_rule_exp : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> bool -> (* multiple (whether the rule was defined with a ::) *) bool -> (* static (whether the results should be cached in .omakedb) *) Omake_value_type.t -> (* key *) Omake_ir.var_info list -> (* variables to be defined *) Omake_node.Node.t -> (* Target *) Omake_value_type.t -> (* sources *) Omake_value_type.t -> (* options *) Omake_value_type.t -> (* commands *) Omake_env.t val eval_shell_exp : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_value_type.t -> Omake_env.t * Omake_value_type.t val eval_shell_output : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> Omake_value_type.t -> string omake-0.10.3/src/build/omake_build_util.mli0000644000175000017500000000644613177364666017251 0ustar gerdgerd val parse_sym : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> string -> Omake_ir.var_info * Omake_ir.var list val is_leaf_command : Omake_build_type.command -> bool (* * A node is a leaf if it has no dependencies and no commands. *) val is_leaf_node : Omake_build_type.t -> Omake_node.Node.t -> bool (* * Unfortunately, we have to specify the environment imperatively. *) val set_env : Omake_build_type.t -> unit val get_env : Omake_value_type.pos -> Lm_location.t -> Omake_build_type.t val is_build_phase : unit -> bool (* * Add a command line variable definition. *) val add_command_def : string -> string -> unit (* * Check if there are command defs. *) val command_defs_are_nonempty : unit -> bool (* * Add all the command-line defs to the encironment. *) val venv_add_command_defs : Omake_env.t -> Omake_env.t (* * Get the object from a file. *) val object_of_file : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> string -> Omake_value_type.obj (* * Test for a dependency. * The symbol is the name of the ordering relation. * The bool is whether to work in debug mode. *) val sort : Omake_build_type.t -> Omake_env.t -> Omake_value_type.pos -> Lm_symbol.t -> Omake_node.Node.t list -> Omake_node.Node.t list val check_sort : Omake_build_type.t -> Omake_env.t -> Omake_value_type.pos -> Lm_symbol.t -> Omake_node.Node.t list -> unit val command_tag : Omake_build_type.command_state -> Omake_build_type.command_tag val get_worklist_command : Omake_build_type.env_wl -> Omake_build_type.command_tag -> Omake_build_type.command option ref val command_worklist : Omake_build_type.t -> Omake_build_type.command_tag -> Omake_build_type.command option ref val create_wl : unit -> Omake_build_type.env_wl val pp_print_command_state : Omake_build_type.command_state Lm_printf.t val pp_print_command : Omake_build_type.command Lm_printf.t val pp_print_node_states : Omake_build_type.t -> Omake_node.NodeSet.t Lm_printf.t val print_stats : Omake_build_type.t -> string -> float -> unit val print_failed : Omake_build_type.t -> Omake_build_type.command_tag Lm_printf.t val print_failed_targets : Omake_build_type.t -> Format.formatter -> unit(* Omake_build_type.t Lm_printf.t *) val command_find : Omake_build_type.t -> Omake_build_type.command_tag -> (Omake_build_type.command -> bool) -> Omake_build_type.command val command_exists : Omake_build_type.t -> Omake_build_type.command_tag -> (Omake_build_type.command -> bool) -> bool -> bool val command_list_head : Omake_build_type.t -> Omake_build_type.command_tag -> Omake_build_type.command val command_iter : Omake_build_type.t -> Omake_build_type.command_tag -> (Omake_build_type.command -> 'a) -> unit val command_list_is_empty : Omake_build_type.t -> Omake_build_type.command_tag -> bool (* * Examining the state. * Note that in a non-standard build phase (such as .DUILD_SUCCESS), * this function will process _both_ the phase-specific worklist and the main worklist. *) val command_fold : Omake_build_type.t -> Omake_build_type.command_tag -> ('a -> Omake_build_type.command -> 'a) -> 'a -> 'a val wait_for_lock : unit -> unit val unlock_db : unit -> unit val eprint_env : Omake_build_type.t -> unit (** Close the environment. *) val close : Omake_build_type.t -> unit omake-0.10.3/src/build/omake_build.mli0000644000175000017500000000046113177364666016203 0ustar gerdgerd val debug_rule : bool ref val debug_build : bool ref val debug_deps : bool ref (* * .omakedb save interval (0 - disable) *) val save_interval : float ref val build : Omake_options.t -> string -> string list -> unit (** Used in osh *) val build_fun : Omake_env.t -> string list -> bool omake-0.10.3/src/build/omake_builtin.mli0000644000175000017500000000113513177364666016551 0ustar gerdgerd (* * Register some builtin info. *) val register_builtin : Omake_builtin_type.builtin_info -> unit (* * Add a command line variable definition. *) val add_command_def : string -> string -> unit (* * Check if there are command defs. *) val command_defs_are_nonempty : unit -> bool (* * Add all the command-line defs to the encironment. *) val venv_add_command_defs : Omake_env.t -> Omake_env.t (* * Builtin functions. *) val venv_add_builtins : Omake_env.t -> Omake_env.t val venv_add_pervasives : Omake_env.t -> Omake_env.t val venv_include_rc_file : Omake_env.t -> string -> Omake_env.t omake-0.10.3/src/build/omake_build_tee.mli0000644000175000017500000000047113177364666017041 0ustar gerdgerd val env_close_success_tee : Omake_build_type.t -> Omake_build_type.command -> unit val env_close_failed_tee : Omake_build_type.t -> Omake_build_type.command -> unit val format_tee_with_nl : Omake_build_type.command Lm_printf.t val unlink_tee : Omake_build_type.command -> unit omake-0.10.3/src/build/omake_target.mli0000644000175000017500000000127613177364666016377 0ustar gerdgerdval target_is_buildable : Omake_cache.t -> Omake_env.t -> Omake_value_type.pos -> Omake_node.Node.t -> bool val target_is_buildable_proper : Omake_cache.t -> Omake_env.t -> Omake_value_type.pos -> Omake_node.Node.t -> bool val venv_find_buildable_implicit_rule : Omake_cache.t -> Omake_env.t -> Omake_value_type.pos -> Omake_node.Node.t -> Omake_env.erule option val target_is_buildable_in_path : Omake_cache.t -> Omake_env.t -> Omake_value_type.pos -> Omake_node.Dir.t list -> string list -> Omake_node.Node.t option val target_is_buildable_in_path_1 : Omake_cache.t -> Omake_env.t -> Omake_value_type.pos -> (Omake_node.Dir.t * Omake_env.target_dir) list -> string list -> Omake_node.Node.t option omake-0.10.3/src/ast/0000755000175000017500000000000013177364666012714 5ustar gerdgerdomake-0.10.3/src/ast/OMakefile0000644000175000017500000000033013177364665014466 0ustar gerdgerdOCAMLINCLUDES[] += ../libmojave FILES[] = omake_ast omake_ast_util omake_ast_print # # The library # MakeOCamlLibrary(ast, $(FILES)) clean: $(CLEAN) # # Generate the Makefile # MakeMakefile() omake-0.10.3/src/ast/omake_ast_print.ml0000644000175000017500000003027513177364665016433 0ustar gerdgerd let pp_print_location = Lm_location.pp_print_location let pp_print_symbol = Lm_symbol.pp_print_symbol module SymbolTable = Lm_symbol.SymbolTable let create_debug = Lm_debug.create_debug let pp_print_method_name = Lm_symbol.pp_print_method_name let print_location = create_debug (**) { debug_name = "print-loc"; debug_description = "Print locations"; debug_value = false } (* * Application strategy. *) let pp_print_strategy buf (s : Omake_ast.apply_strategy) = match s with | LazyApply -> Format.pp_print_char buf '\'' | EagerApply -> Format.pp_print_char buf ',' | NormalApply -> () | CommandApply -> Format.pp_print_char buf '#' (* * Definitions. *) let pp_print_define_kind buf (flag : Omake_ast.define_kind) = match flag with | DefineString -> () | DefineArray -> Format.pp_print_string buf "[]" let pp_print_define_flag buf (flag : Omake_ast.define_flag) = let s = match flag with | DefineNormal -> "=" | DefineAppend -> "+=" in Format.pp_print_string buf s (* * Print an expression. *) let rec pp_print_exp buf (e : Omake_ast.exp)= if !print_location then Format.fprintf buf "<%a>" pp_print_location (Omake_ast_util.loc_of_exp e); match e with | NullExp _ -> Format.pp_print_string buf "" | IntExp (i, _) -> Format.fprintf buf "(int %d)" i | FloatExp (x, _) -> Format.fprintf buf "(float %f)" x | StringOpExp (s, _) -> Format.fprintf buf "(string-op \"%s\")" (String.escaped s) | StringIdExp (s, _) -> Format.fprintf buf "(string-id \"%s\")" (String.escaped s) | StringIntExp (s, _) -> Format.fprintf buf "(string-int \"%s\")" (String.escaped s) | StringFloatExp (s, _) -> Format.fprintf buf "(string-float \"%s\")" (String.escaped s) | StringWhiteExp (s, _) -> Format.fprintf buf "(string-white \"%s\")" (String.escaped s) | StringOtherExp (s, _) -> Format.fprintf buf "(string-other \"%s\")" (String.escaped s) | StringKeywordExp (s, _) -> Format.fprintf buf "(string-keyword \"%s\")" (String.escaped s) | QuoteExp (el, _) -> Format.fprintf buf "@[(quote"; List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_exp e) el; Format.fprintf buf ")@]" | QuoteStringExp (c, el, _) -> Format.fprintf buf "@[(quoted-string %c" c; List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_exp e) el; Format.fprintf buf "%c)@]" c | SequenceExp (el, _) -> Format.fprintf buf "@[(sequence"; List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_exp e) el; Format.fprintf buf ")@]" | ArrayExp (el, _) -> Format.fprintf buf "@[(array"; List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_exp e) el; Format.fprintf buf ")@]" | ApplyExp (LazyApply, v, [], _) -> Format.fprintf buf "$%a" pp_print_symbol v | ApplyExp (s, v, args, _) -> Format.fprintf buf "@[%a%a(%a)@]" (**) pp_print_symbol v pp_print_strategy s pp_print_args args | SuperApplyExp (s, super, v, args, _) -> Format.fprintf buf "@[%a%a::%a(%a)@]" (**) pp_print_symbol super pp_print_strategy s pp_print_symbol v pp_print_args args | MethodApplyExp (s, vl, args, _) -> Format.fprintf buf "@[%a%a(%a)@]" (**) pp_print_method_name vl pp_print_strategy s pp_print_args args | CommandExp (v, arg, commands, _) -> Format.fprintf buf "@[@[command %a(%a) {%a@]@ }@]" (**) pp_print_symbol v pp_print_exp arg pp_print_exp_list commands | VarDefExp (v, kind, flag, e, _) -> Format.fprintf buf "@[let %a%a %a@ %a@]" (**) pp_print_method_name v pp_print_define_kind kind pp_print_define_flag flag pp_print_exp e | VarDefBodyExp (v, kind, flag, el, _) -> Format.fprintf buf "@[let %a%a %a@ %a@]" (**) pp_print_method_name v pp_print_define_kind kind pp_print_define_flag flag pp_print_exp_list el | KeyExp (strategy, v, _) -> Format.fprintf buf "$%a|%s|" pp_print_strategy strategy v | KeyDefExp (v, kind, flag, e, _) -> Format.fprintf buf "@[\"%s\"%a %a@ %a@]" (**) v pp_print_define_kind kind pp_print_define_flag flag pp_print_exp e | KeyDefBodyExp (v, kind, flag, el, _) -> Format.fprintf buf "@[key \"%s\"%a %a@ %a@]" (**) v pp_print_define_kind kind pp_print_define_flag flag pp_print_exp_list el | ObjectDefExp (v, flag, el, _) -> Format.fprintf buf "@[let %a. %a@ %a@]" (**) pp_print_method_name v pp_print_define_flag flag pp_print_exp_list el; | FunDefExp (v, vars, el, _) -> Format.fprintf buf "@[let %a(%a) =" (**) pp_print_params vars pp_print_method_name v; List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_exp e) el; Format.fprintf buf "@]" | RuleExp (multiple, target, pattern, source, commands, _) -> Format.fprintf buf "@[@[rule {@ multiple = %b;@ @[target =@ %a;@]@ @[pattern =@ %a;@]@ @[source =@ %a@]@ %a@]@ }@]" (**) multiple pp_print_exp target pp_print_exp pattern pp_print_table_exp source pp_print_exp_list commands | BodyExp (body, _) -> Format.fprintf buf "@[body"; List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_exp e) body; Format.fprintf buf "@]" | ShellExp (e, _) -> Format.fprintf buf "@[shell %a@]" pp_print_exp e | CatchExp (name, v, body, _) -> Format.fprintf buf "@[catch %a(%a)@ %a@]" (**) pp_print_symbol name pp_print_symbol v pp_print_exp_list body | ClassExp (names, _) -> Format.fprintf buf "@[class"; List.iter (fun v -> Format.fprintf buf "@ %a" pp_print_symbol v) names; Format.fprintf buf "@]" (* * Parameters. *) and pp_print_param buf param = match (param : Omake_ast.param) with | OptionalParam (v, e, _) -> Format.fprintf buf "@[?%a =@ %a@]" pp_print_symbol v pp_print_exp e | RequiredParam (v, _) -> Format.fprintf buf "~%a" pp_print_symbol v | NormalParam (v, _) -> pp_print_symbol buf v and pp_print_params buf vars = match vars with | [v] -> pp_print_param buf v | v :: vars -> Format.fprintf buf "%a,@ " pp_print_param v; pp_print_params buf vars | [] -> () and pp_print_arrow_arg buf params e = Format.fprintf buf "@[%a =>@ %a@]" pp_print_params params pp_print_exp e and pp_print_arg buf (arg : Omake_ast.arg) = match arg with | KeyArg (v, e) -> Format.fprintf buf "@[~%a =@ %a@]" pp_print_symbol v pp_print_exp e | ExpArg e -> pp_print_exp buf e | ArrowArg (params, e) -> pp_print_arrow_arg buf params e and pp_print_args buf (args : Omake_ast.arg list) = match args with | [arg] -> pp_print_arg buf arg | arg :: args -> pp_print_arg buf arg; Format.fprintf buf ",@ "; pp_print_args buf args | [] -> () and pp_print_exp_list buf commands = List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_exp e) commands (* and pp_print_exp_option buf e_opt = *) (* match e_opt with *) (* | Some e -> pp_print_exp buf e *) (* | None -> Format.pp_print_string buf "" *) and pp_print_table_exp buf source = Format.fprintf buf "@[@[{"; SymbolTable.iter (fun v e -> Format.fprintf buf "@ %a = %a" pp_print_symbol v pp_print_exp e) source; Format.fprintf buf "@]@ }@]" (* * A program is a list of expressions. *) let pp_print_prog buf prog = Format.fprintf buf "@[Prog:"; List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_exp e) prog; Format.fprintf buf "@]" (* * Simplified printing. *) let rec pp_print_simple_exp buf (e : Omake_ast.exp) = if !print_location then Format.fprintf buf "<%a>" pp_print_location (Omake_ast_util.loc_of_exp e); match e with | NullExp _ -> Format.pp_print_string buf "" | IntExp (i, _) -> Format.fprintf buf "%d" i | FloatExp (x, _) -> Format.fprintf buf "%f" x | StringOpExp (s, _) | StringIdExp (s, _) | StringIntExp (s, _) | StringFloatExp (s, _) | StringWhiteExp (s, _) | StringOtherExp (s, _) | StringKeywordExp (s, _) -> Format.pp_print_string buf s | QuoteExp (el, _) -> Format.fprintf buf "$'%a'" pp_print_simple_exp_list el | QuoteStringExp (c, el, _) -> Format.fprintf buf "%c%a%c" c pp_print_simple_exp_list el c | SequenceExp (el, _) -> pp_print_simple_exp_list buf el | ArrayExp (el, _) -> Format.fprintf buf "@[(array"; List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_exp e) el; Format.fprintf buf ")@]" | ApplyExp (LazyApply, v, [], _) -> Format.fprintf buf "$%a" pp_print_symbol v | ApplyExp (s, v, args, _) -> Format.fprintf buf "@[%a%a(%a)@]" (**) pp_print_strategy s pp_print_symbol v pp_print_simple_args args | SuperApplyExp (s, super, v, args, _) -> Format.fprintf buf "@[%a%a::%a(%a)@]" (**) pp_print_symbol super pp_print_strategy s pp_print_symbol v pp_print_simple_args args | MethodApplyExp (s, vl, args, _) -> Format.fprintf buf "@[%a%a(%a)@]" (**) pp_print_method_name vl pp_print_strategy s pp_print_simple_args args | CommandExp (v, arg, commands, _) -> Format.fprintf buf "@[@[command %a(%a) {%a@]@ }@]" (**) pp_print_symbol v pp_print_simple_exp arg pp_print_simple_exp_list commands | VarDefExp (v, kind, flag, e, _) -> Format.fprintf buf "@[let %a%a %a@ %a@]" (**) pp_print_method_name v pp_print_define_kind kind pp_print_define_flag flag pp_print_simple_exp e | VarDefBodyExp (v, kind, flag, el, _) -> Format.fprintf buf "@[let %a%a %a@ %a@]" (**) pp_print_method_name v pp_print_define_kind kind pp_print_define_flag flag pp_print_simple_exp_list el | KeyExp (strategy, v, _) -> Format.fprintf buf "$%a|%s|" pp_print_strategy strategy v | KeyDefExp (v, kind, flag, e, _) -> Format.fprintf buf "@[\"%s\"%a %a@ %a@]" (**) v pp_print_define_kind kind pp_print_define_flag flag pp_print_simple_exp e | KeyDefBodyExp (v, kind, flag, el, _) -> Format.fprintf buf "@[key \"%s\"%a %a@ %a@]" (**) v pp_print_define_kind kind pp_print_define_flag flag pp_print_simple_exp_list el | ObjectDefExp (v, flag, el, _) -> Format.fprintf buf "@[let %a. %a@ %a@]" (**) pp_print_method_name v pp_print_define_flag flag pp_print_simple_exp_list el | FunDefExp (v, vars, el, _) -> Format.fprintf buf "@[let %a(%a) =" (**) pp_print_params vars pp_print_method_name v; List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_exp e) el; Format.fprintf buf "@]" | RuleExp (multiple, target, pattern, source, commands, _) -> Format.fprintf buf "@[@[rule {@ multiple = %b;@ @[target =@ %a;@]@ @[pattern =@ %a;@]@ @[source =@ %a@]@ %a@]@ }@]" (**) multiple pp_print_simple_exp target pp_print_simple_exp pattern pp_print_table_exp source pp_print_simple_exp_list commands | BodyExp (body, _) -> Format.fprintf buf "@[body"; List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_simple_exp e) body; Format.fprintf buf "@]" | ShellExp (e, _) -> Format.fprintf buf "@[shell %a@]" pp_print_simple_exp e | CatchExp (name, v, body, _) -> Format.fprintf buf "@[catch %a(%a)@ %a@]" (**) pp_print_symbol name pp_print_symbol v pp_print_simple_exp_list body | ClassExp (names, _) -> Format.fprintf buf "@[class"; List.iter (fun v -> Format.fprintf buf "@ %a" pp_print_symbol v) names; Format.fprintf buf "@]" and pp_print_simple_exp_list buf el = List.iter (pp_print_simple_exp buf) el and pp_print_simple_args buf args = match args with | [arg] -> pp_print_simple_arg buf arg | arg :: args -> pp_print_simple_arg buf arg; Format.fprintf buf ",@ "; pp_print_simple_args buf args | [] -> () and pp_print_simple_arg buf (arg : Omake_ast.arg) = match arg with | KeyArg (v, e) -> Format.fprintf buf "@[~%a =@ %a@]" pp_print_symbol v pp_print_exp e | ExpArg e -> pp_print_simple_exp buf e | ArrowArg (params, e) -> pp_print_arrow_arg buf params e omake-0.10.3/src/ast/omake_ast.ml0000644000175000017500000001445113177364665015215 0ustar gerdgerd(* Abstract syntax of OMakefiles. *) type var = Lm_symbol.t (* * Shell flags indicating whether a body needs to be read. * GS: Many parsing functions return whether a body follows, and which: NoBody no body follows OptBody a body may follow (subexpression) ColonBody a body will follow. In the interactive mode this is indicated by a colon at the end of the line, hence the name ArrayBody a body interpreted as array will follow. Used for "V[] =". *) type body_flag = | NoBody | OptBody | ColonBody | ArrayBody (* * Function applications can be tagged as Lazy or Eager. * GS. Also used for variables etc. LazyApply is an _explicitly_ lazy * application (e.g. $`x) and EagerApply an _explicitly_ eager application * (e.g. $,x). Both overriding any evaluation strategy that was recorded * with the variable. * * GS. CommandApply: seeing this where a command is run (notation Cmd(...)). * I guess it means that the result is discarded *) type apply_strategy = | LazyApply | EagerApply | NormalApply | CommandApply (* * When a variable is defined, these are additional flags. * The bool is true if this is an array operation. *) type define_kind = | DefineString | DefineArray type define_flag = | DefineNormal | DefineAppend (* * Expressions. * * The String*Exp are all strings. Normally, they are all interpreted * the same way. * * GS: * NullExp sometimes used for missing expression, e.g. missing * argument * IntExp an integer (only used when int parsing is obligatory) * FloatExp a float (only used when int parsing is obligatory) * StringOpExp string that parses as special char/string, e.g. "::" * or "=>" * StringIdExp string that parses as name * StringIntExp string that parses as integer * StringFloatExp string that parses as float * StringWhiteExp string that parses as whitespace * StringKeywordExp string that parses as keyword * StringOtherExp other string * QuoteExp range quoted with $"" * QuoteStringExp range in double quotes * SequenceExp string sequence (concatenation) * ArrayExp an argument is tagged as ArrayExp if it came from an * array body (not returned by parser, later added by * Omake_ast_util.update_body_args) * ApplyExp(CommandApply,...) * call a command (syntax Cmd(...)). Args may be given * as body or inline * ApplyExp(_,...) call a function ($(name arg) - resulting in a value) * ApplyExp(...,var,[]) look up a variable (like function call with empty args) * MethodApplyExp call a method command (syntax obj.Cmd(...)) * SuperApplyExp call a super method command * CommandExp the "var" is the symbol for the command to run. * Used for builtins like "if", "match" etc. * VarDefExp variable assignment (inline w/o body, v = ...) * VarDefBodyExp variable assignment (w/ body, v =) * ObjectDefExp object definition (w/body, v. =) * FunDefExp function definition (w/ body, v(args) =) * RuleExp a rule (2- or 3-place) * ShellExp an external command to run (new process) * BodyExp an argument is tagged as BodyExp if it came from a * non-array body (not returned by parser, later added by * Omake_ast_util.update_body_args) * CatchExp "catch" expression (unclear why this doesn't fit into * CommandExp) * ClassExp "class" expression * KeyExp key lookup (|name|) * KeyDefExp key assignment (inline w/o body, |name| = ...) * KeyDefBodyExp key assignment (w/body, |name| =) *) type exp = | NullExp of Lm_location.t | IntExp of int * Lm_location.t | FloatExp of float * Lm_location.t | StringOpExp of string * Lm_location.t | StringIdExp of string * Lm_location.t | StringIntExp of string * Lm_location.t | StringFloatExp of string * Lm_location.t | StringWhiteExp of string * Lm_location.t | StringOtherExp of string * Lm_location.t | StringKeywordExp of string * Lm_location.t | QuoteExp of exp list * Lm_location.t | QuoteStringExp of char * exp list * Lm_location.t | SequenceExp of exp list * Lm_location.t | ArrayExp of exp list * Lm_location.t | ApplyExp of apply_strategy * var * arg list * Lm_location.t | SuperApplyExp of apply_strategy * var * var * arg list * Lm_location.t | MethodApplyExp of apply_strategy * var list * arg list * Lm_location.t | CommandExp of var * exp * exp list * Lm_location.t | VarDefExp of var list * define_kind * define_flag * exp * Lm_location.t | VarDefBodyExp of var list * define_kind * define_flag * exp list * Lm_location.t | ObjectDefExp of var list * define_flag * exp list * Lm_location.t | FunDefExp of var list * params * exp list * Lm_location.t | RuleExp of bool * exp * exp * exp Lm_symbol.SymbolTable.t * exp list * Lm_location.t | BodyExp of exp list * Lm_location.t | ShellExp of exp * Lm_location.t | CatchExp of var * var * exp list * Lm_location.t | ClassExp of Lm_symbol.t list * Lm_location.t | KeyExp of apply_strategy * string * Lm_location.t | KeyDefExp of string * define_kind * define_flag * exp * Lm_location.t | KeyDefBodyExp of string * define_kind * define_flag * exp list * Lm_location.t and params = param list (* GS. param = formal param of a lambda *) and param = | OptionalParam of var * exp * Lm_location.t | RequiredParam of var * Lm_location.t | NormalParam of var * Lm_location.t (* GS. arg = actual argument of an application *) and arg = | KeyArg of var * exp | ExpArg of exp | ArrowArg of param list * exp and parse_arg = | IdArg of string * (string * Lm_location.t) option * Lm_location.t (* Second string is always whitespace *) | NormalArg of arg and args = arg list type prog = exp list omake-0.10.3/src/ast/omake_ast_util.ml0000644000175000017500000004070513177364666016254 0ustar gerdgerdlet loc_of_exp (e : Omake_ast.exp) = match e with | NullExp loc | IntExp (_, loc) | FloatExp (_, loc) | StringOpExp (_, loc) | StringIdExp (_, loc) | StringIntExp (_, loc) | StringFloatExp (_, loc) | StringWhiteExp (_, loc) | StringOtherExp (_, loc) | StringKeywordExp (_, loc) | QuoteExp (_, loc) | QuoteStringExp (_, _, loc) | SequenceExp (_, loc) | ArrayExp (_, loc) | ApplyExp (_, _, _, loc) | SuperApplyExp (_, _, _, _, loc) | MethodApplyExp (_, _, _, loc) | CommandExp (_, _, _, loc) | VarDefExp (_, _, _, _, loc) | VarDefBodyExp (_, _, _, _, loc) | KeyExp (_, _, loc) | KeyDefExp (_, _, _, _, loc) | KeyDefBodyExp (_, _, _, _, loc) | FunDefExp (_, _, _, loc) | ObjectDefExp (_, _, _, loc) | RuleExp (_, _, _, _, _, loc) | BodyExp (_, loc) | ShellExp (_, loc) | CatchExp (_, _, _, loc) | ClassExp (_, loc) -> loc (* * Get a key word that describes the expression. *) let rec last vl = match vl with | [v] -> v | _ :: vl -> last vl | [] -> invalid_arg "last" let key_of_exp (e : Omake_ast.exp ) = match e with | NullExp _ -> "null" | IntExp _ | FloatExp _ | StringOpExp _ | StringIdExp _ | StringIntExp _ | StringFloatExp _ | StringWhiteExp _ | StringOtherExp _ | StringKeywordExp _ | QuoteExp _ | QuoteStringExp _ | SequenceExp _ | ArrayExp _ -> "string" | ApplyExp (_, v, _, _) | CommandExp (v, _, _, _) | SuperApplyExp (_, v, _, _, _) -> Lm_symbol.to_string v | VarDefExp (vl, _, _, _, _) | VarDefBodyExp (vl, _, _, _, _) | ObjectDefExp (vl, _, _, _) | FunDefExp (vl, _, _, _) | MethodApplyExp (_, vl, _, _) -> Lm_symbol.to_string (last vl) | KeyExp _ | KeyDefExp _ | KeyDefBodyExp _ -> "key" | RuleExp _ -> "rule" | BodyExp _ -> "body" | ShellExp _ -> "shell" | CatchExp _ -> "catch" | ClassExp _ -> "class" (* * In an argument list, each ... is replaced by the body. * If there is no elision, then the body is added as the * first argument. *) let is_elide_exp (e : Omake_ast.exp) = match e with | StringOpExp ("...", _) | StringOpExp ("[...]", _) -> true | _ -> false let add_elide_code _loc (code1 : Omake_ast.body_flag) (code2 : Omake_ast.body_flag) = match code1, code2 with | NoBody, code | code, NoBody -> code | OptBody, code | code, OptBody -> code | _ -> if code1 = code2 then code1 else raise (Invalid_argument "conflicting elisions") let scan_elide_args code args = List.fold_left (fun code (arg : Omake_ast.arg) -> let arg = match arg with | KeyArg (_, e) | ExpArg e | ArrowArg (_, e) -> Some e in match arg with | Some (StringOpExp ("...", loc)) -> add_elide_code loc code ColonBody | Some (StringOpExp ("[...]", loc)) -> add_elide_code loc code ArrayBody | _ -> code) code args let scan_body_flag code (e : Omake_ast.exp) = match e with | ApplyExp (_, _, args, _) | SuperApplyExp (_, _, _, args, _) | MethodApplyExp (_, _, args, _) -> scan_elide_args code args | _ -> code (* GS. The lexer/parser primarily works line by line. Many constructs have * forms where the arguments are given by "bodies" starting on the next line * (and indented). E.g. * if * * else * * The parser returns first a version of "if" (ApplyExp(...,"if")) without args * but also returns a marker that a body will come. * The function calling the parser (which is funnily in the lexer module * Omake_ast_lex) checks for such markers, and parses the body separately, * and calls one of the following functions to enter the body into the * originally returned expression as arguments. These specially handled * bodies are marked in the expression with the special BodyExp and ArrayExp * nodes (the latter for array bodies). *) let update_body_args loc (code : Omake_ast.body_flag) body args = let body : Omake_ast.exp= match code with | NoBody | OptBody | ColonBody -> BodyExp (body, loc) | ArrayBody -> ArrayExp (body, loc) in let rev_args, found = List.fold_left (fun (args, found) (arg : Omake_ast.arg) -> let arg, found = match arg with | KeyArg (v, e) -> if is_elide_exp e then Omake_ast.KeyArg (v, body), true else arg, found | ExpArg e -> if is_elide_exp e then ExpArg body, true else arg, found | ArrowArg (params, e) -> if is_elide_exp e then ArrowArg (params, body), true else arg, found in arg :: args, found) ([], false) args in let args = List.rev rev_args in if found then args else ExpArg body :: args (* * In an argument list, each ... is replaced by the body. * If there is no elision, then the body is added as the * first argument. *) let update_body_exp e code body : Omake_ast.exp = match (e : Omake_ast.exp) with | NullExp _ | IntExp _ | FloatExp _ | StringOpExp _ | StringIdExp _ | StringIntExp _ | StringFloatExp _ | StringWhiteExp _ | StringOtherExp _ | StringKeywordExp _ | QuoteExp _ | QuoteStringExp _ | SequenceExp _ | ArrayExp _ | VarDefExp _ | KeyExp _ | KeyDefExp _ | BodyExp _ | ShellExp _ | ClassExp _ -> raise (Invalid_argument "update_body") | ApplyExp (strategy, v, args, loc) -> ApplyExp (strategy, v, update_body_args loc code body args, loc) | SuperApplyExp (strategy, super, v, args, loc) -> SuperApplyExp (strategy, super, v, update_body_args loc code body args, loc) | MethodApplyExp (strategy, vl, args, loc) -> MethodApplyExp (strategy, vl, update_body_args loc code body args, loc) | CommandExp (v, e, _, loc) -> CommandExp (v, e, body, loc) | VarDefBodyExp (v, kind, flag, _, loc) -> VarDefBodyExp (v, kind, flag, body, loc) | KeyDefBodyExp (v, kind, flag, _, loc) -> KeyDefBodyExp (v, kind, flag, body, loc) | ObjectDefExp (v, flag, _, loc) -> ObjectDefExp (v, flag, body, loc) | FunDefExp (v, params, _, loc) -> FunDefExp (v, params, body, loc) | RuleExp (flag, target, pattern, sources, _, loc) -> RuleExp (flag, target, pattern, sources, body, loc) | CatchExp (name, v, _, loc) -> CatchExp (name, v, body, loc) let update_body e (code : Omake_ast.body_flag) body = match code, body with | NoBody, [] | OptBody, [] | ColonBody, [] -> e | ArrayBody, _ | _, _ :: _ -> update_body_exp e code body (* * Indicate whether the command may have remaining parts. *) let continue_commands = ["if", "else"; "elseif", "else"; "switch", "case"; "match", "case"; "lexer", "case"; "case", "case"; "default", "case"; "try", "catch"; "catch", "catch"] let continue_syms = List.fold_left (fun set (s1, s2) -> Lm_symbol.SymbolTable.add set (Lm_symbol.add s1) s2) Lm_symbol.SymbolTable.empty continue_commands let can_continue (e : Omake_ast.exp) = match e with | NullExp _ | IntExp _ | FloatExp _ | StringIdExp _ | StringOpExp _ | StringIntExp _ | StringFloatExp _ | StringWhiteExp _ | StringOtherExp _ | StringKeywordExp _ | QuoteExp _ | QuoteStringExp _ | SequenceExp _ | ArrayExp _ | ApplyExp _ | SuperApplyExp _ | MethodApplyExp _ | VarDefExp _ | VarDefBodyExp _ | KeyExp _ | KeyDefExp _ | KeyDefBodyExp _ | ObjectDefExp _ | FunDefExp _ | RuleExp _ | BodyExp _ | ShellExp _ | ClassExp _ -> None | CatchExp _ -> Some "catch" | CommandExp (v, _, _, _) -> try Some (Lm_symbol.SymbolTable.find continue_syms v) with Not_found -> None (************************************************************************ * Sequence flattening. *) (* GS = collapse nested Sequence expressions into a single Sequence *) (* GS TODO: Define a generic mapper for AST expressions, and both sequence * and string flattening with the help of this mapper. *) let rec flatten_exp (e : Omake_ast.exp) = match e with | NullExp _ | IntExp _ | FloatExp _ | ClassExp _ | KeyExp _ | StringOpExp _ | StringIdExp _ | StringIntExp _ | StringWhiteExp _ | StringFloatExp _ | StringOtherExp _ | StringKeywordExp _ -> e (* Sequences *) | QuoteExp (el, loc) -> QuoteExp (flatten_body el, loc) | QuoteStringExp (c, el, loc) -> QuoteStringExp (c, flatten_body el, loc) | SequenceExp (el, loc) -> SequenceExp (flatten_body el, loc) (* Descend into the terms *) | ArrayExp (el, loc) -> ArrayExp (flatten_exp_list el, loc) | ApplyExp (strategy, v, args, loc) -> ApplyExp (strategy, v, flatten_arg_list args, loc) | SuperApplyExp (strategy, v1, v2, args, loc) -> SuperApplyExp (strategy, v1, v2, flatten_arg_list args, loc) | MethodApplyExp (strategy, vl, args, loc) -> MethodApplyExp (strategy, vl, flatten_arg_list args, loc) | CommandExp (v, e, el, loc) -> CommandExp (v, flatten_exp e, flatten_body el, loc) | VarDefExp (vl, kind, flag, e, loc) -> VarDefExp (vl, kind, flag, flatten_exp e, loc) | VarDefBodyExp (vl, kind, flag, el, loc) -> VarDefBodyExp (vl, kind, flag, flatten_body_kind kind el, loc) | ObjectDefExp (vl, flag, el, loc) -> ObjectDefExp (vl, flag, flatten_body el, loc) | FunDefExp (vl, params, el, loc) -> FunDefExp (vl, flatten_param_list params, flatten_body el, loc) | RuleExp (multiple, target, pattern, options, body, loc) -> RuleExp (multiple, flatten_exp target, flatten_exp pattern, flatten_table_exp options, flatten_body body, loc) | BodyExp (el, loc) -> BodyExp (flatten_body el, loc) | CatchExp (v1, v2, el, loc) -> CatchExp (v1, v2, flatten_body el, loc) | KeyDefExp (s, kind, flag, e, loc) -> KeyDefExp (s, kind, flag, flatten_exp e, loc) | KeyDefBodyExp (s, kind, flag, el, loc) -> KeyDefBodyExp (s, kind, flag, flatten_body_kind kind el, loc) | ShellExp (e, loc) -> ShellExp (flatten_exp e, loc) and flatten_exp_list el = List.map flatten_exp el and flatten_arg (arg : Omake_ast.arg) : Omake_ast.arg = match arg with | KeyArg (v, e) -> KeyArg (v, flatten_exp e) | ExpArg e -> ExpArg (flatten_exp e) | ArrowArg (params, e) -> ArrowArg (flatten_param_list params, flatten_exp e) and flatten_arg_list args = List.map flatten_arg args and flatten_param (param : Omake_ast.param) : Omake_ast.param = match param with | OptionalParam (v, e, loc) -> OptionalParam (v, flatten_exp e, loc) | RequiredParam _ | NormalParam _ as param -> param and flatten_param_list params = List.map flatten_param params and flatten_table_exp table = Lm_symbol.SymbolTable.map flatten_exp table and flatten_body_kind (kind : Omake_ast.define_kind) el = match kind with | DefineString -> flatten_body el | DefineArray -> flatten_exp_list el and flatten_body el = flatten_body_aux [] el [] and flatten_body_aux items (el : Omake_ast.exp list) (ell : Omake_ast.exp list list) = match el, ell with | [], [] -> List.rev items | [], el :: ell -> flatten_body_aux items el ell | e :: el, _ -> match e with | SequenceExp (el2, _) -> flatten_body_aux items el2 (el :: ell) | NullExp _ -> flatten_body_aux items el ell | _ -> let items = flatten_exp e :: items in flatten_body_aux items el ell let flatten_sequence_prog = flatten_body (************************************************************************ * String flattening. *) (* = collapse nested Sequence expressions into a single StringOtherExp. Also give up on the special nodes for parsed strings (except StringQhiteExp) *) let rec string_exp (e : Omake_ast.exp) = match e with | NullExp _ | IntExp _ | FloatExp _ | ClassExp _ | KeyExp _ | StringWhiteExp _ -> e | StringOpExp (s, loc) | StringIdExp (s, loc) | StringIntExp (s, loc) | StringFloatExp (s, loc) | StringOtherExp (s, loc) | StringKeywordExp (s, loc) -> StringOtherExp (s, loc) (* Sequences *) | QuoteExp (el, loc) -> QuoteExp (flatten_string_list_exp (string_exp_list el), loc) | QuoteStringExp (c, el, loc) -> QuoteStringExp (c, flatten_string_list_exp (string_exp_list el), loc) | SequenceExp (el, loc) -> string_sequence_exp (string_exp_list el) loc (* Descend into the terms *) | ArrayExp (el, loc) -> ArrayExp (string_exp_list el, loc) | ApplyExp (strategy, v, args, loc) -> ApplyExp (strategy, v, string_arg_list args, loc) | SuperApplyExp (strategy, v1, v2, args, loc) -> SuperApplyExp (strategy, v1, v2, string_arg_list args, loc) | MethodApplyExp (strategy, vl, args, loc) -> MethodApplyExp (strategy, vl, string_arg_list args, loc) | CommandExp (v, e, el, loc) -> CommandExp (v, string_exp e, string_body el, loc) | VarDefExp (vl, kind, flag, e, loc) -> VarDefExp (vl, kind, flag, string_exp e, loc) | VarDefBodyExp (vl, kind, flag, el, loc) -> VarDefBodyExp (vl, kind, flag, string_body el, loc) | ObjectDefExp (vl, flag, el, loc) -> ObjectDefExp (vl, flag, string_body el, loc) | FunDefExp (vl, params, el, loc) -> FunDefExp (vl, string_param_list params, string_body el, loc) | RuleExp (multiple, target, pattern, options, body, loc) -> RuleExp (multiple, string_exp target, string_exp pattern, string_table_exp options, string_body body, loc) | BodyExp (el, loc) -> BodyExp (string_body el, loc) | CatchExp (v1, v2, el, loc) -> CatchExp (v1, v2, string_body el, loc) | KeyDefExp (s, kind, flag, e, loc) -> KeyDefExp (s, kind, flag, string_exp e, loc) | KeyDefBodyExp (s, kind, flag, el, loc) -> KeyDefBodyExp (s, kind, flag, string_body el, loc) | ShellExp (e, loc) -> ShellExp (string_exp e, loc) and string_exp_list el = List.map string_exp el and string_body el = string_exp_list el and string_arg (arg : Omake_ast.arg) : Omake_ast.arg = match arg with | KeyArg (v, e) -> KeyArg (v, string_exp e) | ExpArg e -> ExpArg (string_exp e) | ArrowArg (params, e) -> ArrowArg (string_param_list params, string_exp e) and string_arg_list args = List.map string_arg args and string_param (param : Omake_ast.param) : Omake_ast.param = match param with | OptionalParam (v, e, loc) -> OptionalParam (v, string_exp e, loc) | RequiredParam _ | NormalParam _ as param -> param and string_param_list params = List.map string_param params and string_table_exp table = Lm_symbol.SymbolTable.map string_exp table and string_sequence_exp el loc : Omake_ast.exp = match flatten_string_list_exp el with | [] -> NullExp loc | [e] -> e | el -> SequenceExp (el, loc) and flatten_string_list_exp el = let buf = Buffer.create 32 in (* Flush the buffer *) let flush_buffer buf_opt (args : Omake_ast.exp list) : Omake_ast.exp list = match buf_opt with | Some loc -> let args = Omake_ast.StringOtherExp (Buffer.contents buf, loc) :: args in Buffer.clear buf; args | None -> args in (* Add a constant string to the buffer *) let add_string buf_opt s loc = Buffer.add_string buf s; match buf_opt with | Some loc' -> let loc = Lm_location.union_loc loc' loc in Some loc | None -> Some loc in (* Collect all the strings in the sequence *) let rec collect buf_opt args (el : Omake_ast.exp list) (ell : Omake_ast.exp list list) = match el, ell with | [], [] -> List.rev (flush_buffer buf_opt args) | [], el :: ell -> collect buf_opt args el ell | e :: el, ell -> match e with | NullExp _ -> collect buf_opt args el ell | StringOpExp (s, loc) | StringIdExp (s, loc) | StringIntExp (s, loc) | StringFloatExp (s, loc) | StringOtherExp (s, loc) | StringKeywordExp (s, loc) -> let buf_opt = add_string buf_opt s loc in collect buf_opt args el ell | SequenceExp (el2, _) -> collect buf_opt args el2 (el :: ell) | StringWhiteExp _ | IntExp _ | FloatExp _ | KeyExp _ | ClassExp _ | QuoteStringExp _ | QuoteExp _ | ArrayExp _ | ApplyExp _ | SuperApplyExp _ | MethodApplyExp _ | CommandExp _ | VarDefExp _ | VarDefBodyExp _ | ObjectDefExp _ | FunDefExp _ | RuleExp _ | BodyExp _ | CatchExp _ | KeyDefExp _ | KeyDefBodyExp _ | ShellExp _ -> let args = flush_buffer buf_opt args in collect None (e :: args) el ell in collect None [] el [] let flatten_string_prog = string_exp_list omake-0.10.3/src/ast/omake_ast_print.mli0000644000175000017500000000036713177364666016604 0ustar gerdgerd val print_location : bool ref val pp_print_strategy : Omake_ast.apply_strategy Lm_printf.t val pp_print_exp : Omake_ast.exp Lm_printf.t val pp_print_prog : Omake_ast.exp list Lm_printf.t val pp_print_simple_exp : Omake_ast.exp Lm_printf.t omake-0.10.3/src/ast/omake_ast_util.mli0000644000175000017500000000067113177364666016423 0ustar gerdgerd val loc_of_exp : Omake_ast.exp -> Lm_location.t val key_of_exp : Omake_ast.exp -> string val scan_body_flag : Omake_ast.body_flag -> Omake_ast.exp -> Omake_ast.body_flag val update_body : Omake_ast.exp -> Omake_ast.body_flag -> Omake_ast.exp list -> Omake_ast.exp val can_continue : Omake_ast.exp -> string option val flatten_sequence_prog : Omake_ast.prog -> Omake_ast.prog val flatten_string_prog : Omake_ast.prog -> Omake_ast.prog omake-0.10.3/src/clib/0000755000175000017500000000000013177364666013036 5ustar gerdgerdomake-0.10.3/src/clib/OMakefile0000644000175000017500000000275513177364665014625 0ustar gerdgerd# # This is indirecto to be compatible with nmake # EXTERNAL = ../libmojave-external # CUTIL_FILES[] = # lm_heap.c # lm_heap.h # lm_channel.c # lm_compat_win32.c # lm_compat_win32.h # lm_ctype.c # lm_printf.c # lm_uname_ext.c # lm_unix_cutil.c # unixsupport.h # fam_win32.c # fam_kqueue.c # fam_inotify.c # fam_pseudo.h # lm_notify.c # inotify.h # inotify-syscalls.h # inotify.om # lm_termsize.c # lm_terminfo.c # lm_fs_case_sensitive.c # MakeLinkExternal($(EXTERNAL)/cutil, $(CUTIL_FILES)) # CGeneratedFiles($(CUTIL_FILES)) CC = $(OCAML_CC) CFLAGS += $(OCAML_CFLAGS) # append variables to propagate omake CFLAGS such as $(FAM_CFLAGS) open configure/snprintf open configure/posix_spawn open configure/fs_case_sensitive open configure/moncontrol if $(SNPRINTF_AVAILABLE) CFLAGS += -DHAVE_SNPRINTF export if $(DETECT_FS_CASE_SENSITIVE) CFLAGS += $(DETECT_FS_CASE_SENSITIVE_CFLAGS) export if $(POSIX_SPAWN_AVAILABLE) CFLAGS += -DHAVE_POSIX_SPAWN export if $(MONCONTROL_AVAILABLE) CFLAGS += -DHAVE_MONCONTROL export FILES[] = lm_channel lm_printf lm_ctype lm_uname_ext lm_unix_cutil lm_compat_win32 readline omake_shell_sys omake_shell_spawn fam_win32 fam_kqueue fam_inotify lm_notify lm_termsize lm_terminfo lm_fs_case_sensitive MakeStaticCLibrary(clib, $(FILES)) clean: $(CLEAN) # # Generate the Makefile # MakeMakefile() omake-0.10.3/src/clib/lm_compat_win32.h0000644000175000017500000000343713177364666016213 0ustar gerdgerd/* * Compatibility functions for the various versions of Windows. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] */ #ifndef _COMPAT_WIN32_H #define _COMPAT_WIN32_H #ifdef WIN32 #include #include int ExistsOpenThread(void); HANDLE CompatOpenThread(DWORD arg1, BOOL arg2, DWORD arg3); BOOL CompatGetLongPathName(LPCTSTR arg1, LPTSTR arg2, DWORD arg3); HANDLE CompatCreateToolhelp32Snapshot(DWORD arg1, DWORD arg2); BOOL CompatThread32First(HANDLE arg1, LPTHREADENTRY32 arg2); BOOL CompatThread32Next(HANDLE arg1, LPTHREADENTRY32 arg2); HRESULT CompatSHGetFolderPath(HWND hwndOwner, int nFolder, HANDLE hToken, DWORD dwFlags, LPTSTR pszPath); #endif /* WIN32 */ #endif /* _COMPAT_WIN32_H */ omake-0.10.3/src/clib/lm_heap.h0000644000175000017500000000240113177364666014611 0ustar gerdgerd/* * Some debugging code for the heap. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2006 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] */ #ifndef _HEAP_H #define _HEAP_H value heap_check(value v_unit); #endif /* _HEAP_H */ omake-0.10.3/src/clib/fam_pseudo.h0000644000175000017500000000742313177364666015337 0ustar gerdgerd/* * This presents a FAM-like interface for systems without FAM. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] */ #ifdef FAM_PSEUDO #ifdef FAM_ENABLED #ifndef _FAM_PSEUDO #define _FAM_PSEUDO /* * Maximum number of directories that we will monitor. */ #define MAX_DIR_COUNT 1024 /* * Maximum file name length. */ #define NAME_MAX 1024 /* * Possible events. */ typedef enum { FAMChanged = 1, FAMDeleted = 2, FAMStartExecuting = 3, FAMStopExecuting = 4, FAMCreated = 5, FAMMoved = 6, FAMAcknowledge = 7, FAMExists = 8, FAMEndExist = 9, FAMDirectoryChanged = 10 /* Not standard FAM -- member of dir changed */ } FAMCodes; /* * A request is just a number. */ typedef struct request { int reqnum; } FAMRequest; /* * Events are saved in a linked list. */ typedef struct fam_event { struct fam_connection *fc; // Server FAMRequest fr; // Request number for the directory FAMCodes code; // Event code void *userdata; // User data from the directory char filename[NAME_MAX]; // Name of the file that changed struct fam_event *next; // Linked list } FAMEvent; /* * Server has a collection of directories. */ typedef struct fam_connection { /* Unique identifier */ int id; /* Directories are kept in an array by request number */ unsigned dir_count; struct dir_info *dirs[MAX_DIR_COUNT]; /* Events to pass back to the user */ FAMEvent *event; FAMEvent *last; } FAMConnection; /* * Errors. */ #define FAM_NO_ERROR 0 #define FAM_TOO_MANY_DIRECTORIES 1 #define FAM_DIRECTORY_DOES_NOT_EXIST 2 #define FAM_WINDOWS_ERROR 3 #define FAM_OUT_OF_MEMORY 4 #define FAM_BAD_REQUEST_NUMBER 5 #define FAM_ALREADY_EXISTS 6 #define FAM_NOT_IMPLEMENTED 7 #define FAM_PERMISSION_DENIED 8 #define FAM_UNKNOWN_ERROR 9 extern int FAMErrno; extern char *FamErrlist[]; int FAMOpen(FAMConnection *fc); int FAMClose(FAMConnection *fc); int FAMMonitorDirectory(FAMConnection *fc, const char *name, FAMRequest *request, void *userdata); int FAMSuspendMonitor(FAMConnection *fc, FAMRequest *request); int FAMResumeMonitor(FAMConnection *fc, FAMRequest *request); int FAMCancelMonitor(FAMConnection *fc, FAMRequest *request); int FAMNextEvent(FAMConnection *fc, FAMEvent *event); int FAMPending(FAMConnection *fc); int FAMMonitorDirectoryTree(FAMConnection *fc, const char *name, FAMRequest *request, void *userdata); #endif /* _FAM_PSEUDO */ #endif /* FAM_ENABLED */ #endif /* FAM_PSEUDO */ omake-0.10.3/src/clib/unixsupport.h0000644000175000017500000000355313177364666015635 0ustar gerdgerd/* * Hacking into OCaml. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2006 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] */ #ifndef _UNIXSUPPORT_H #define _UNIXSUPPORT_H #ifdef WIN32 /* * HACK: this gets the handle from a file_descr. * This depends on the OCaml implementation, but * it is unlikely to change. */ struct filedescr { union { HANDLE handle; SOCKET socket; } fd; enum { KIND_HANDLE, KIND_SOCKET } kind; int crt_fd; }; #define Handle_val(v) (((struct filedescr *) Data_custom_val(v))->fd.handle) #define Socket_val(v) (((struct filedescr *) Data_custom_val(v))->fd.socket) #define Descr_kind_val(v) (((struct filedescr *) Data_custom_val(v))->kind) #else /* !WIN32 */ #define Socket_val(v) (Int_val(v)) #endif /* !WIN32 */ #endif /* _UNIX_SUPPORT_H */ omake-0.10.3/src/clib/omake_shell_sys.c0000644000175000017500000010175213177364666016371 0ustar gerdgerd/* * Shell utilities. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004 Jason Hickey, Caltech * * 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; version 2 * of the License. * * 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, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * * Additional permission is given to link this library with the * with the Objective Caml runtime, and to redistribute the * linked executables. See the file LICENSE.OMake for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] */ #include #include #include #include #include #include #ifdef WIN32 #include /* Disable some of the warnings */ #pragma warning( disable : 4127 4189 4702 4706 4996 ) #ifndef _WIN32_WINNT #define _WIN32_WINNT 0x0400 #endif #include "caml/unixsupport.h" //#include #include //#include #include "lm_compat_win32.h" #define Val_nil (Val_int(0)) /* * Fields of the create_process struct. */ #define CREATE_PROCESS_STDIN 0 #define CREATE_PROCESS_STDOUT 1 #define CREATE_PROCESS_STDERR 2 #define CREATE_PROCESS_PGRP 3 #define CREATE_PROCESS_DIR 4 #define CREATE_PROCESS_ENV 5 #define CREATE_PROCESS_EXE 6 #define CREATE_PROCESS_ARGV 7 /* * Tags for Unix status codes. */ #define TAG_WEXITED 0 #define TAG_WSIGNALED 1 #define TAG_WSTOPPED 2 /* * String sizes for creating commands. */ #define SIZEOF_ENVIRONMENT (1 << 15) #define SIZEOF_COMMAND (1 << 15) /* * Max number of threads we can enumerate in a process. */ #define MAX_THREAD_COUNT 1024 /* * Processes and groups. * * Win32 doesn't really have much idea of process groups. * The CreateProcess function just allows processes to be created * in a "process group" that does not get signals from the * console. * * However, we try to do something more. We assign each * process to a process group (number). An entire process * group can be signaled at once. * * However, if more than one process wants input from the * console, they fight it out... */ /* Process status */ #define STATUS_RUNNING 0 #define STATUS_STOPPED 1 #define STATUS_EXITED 2 /* * The root process has pid/pgrp 1. * The null process id usually refers to the current process. */ #define NULL_PID 0 #define INIT_PID 1 #define MAX_PID 29999 /* * The process is group leader if pid and pgrp are the same. */ typedef struct _process { int pid; // Process identifier int pgrp; // Process group DWORD thread; // Identifier if this is a thread unsigned is_thread : 1; // Set if this is a thread unsigned killed : 1; // Set if the process is being killed unsigned changed : 1; // Some even happened on this process unsigned status : 2; // Process status unsigned code : 8; // Exit code, if the process exited HANDLE handle; // The actual process (or event if this is a thread) DWORD wid; // Process identifier struct _process *next; // Linked list } Process; typedef struct _shell_state { int pid_counter; // Index for assigning process ids HANDLE changed; // Wake up the wait handler HANDLE console; // Console handle, if it exists int current_pgrp; // Current tty process group Process *processes; // List of processes } ShellState; /* * The state. */ static ShellState *state = NULL; /************************************************ * Utilities. */ /* * Print an error message. */ static void print_error_code(const char *name, DWORD code) { LPTSTR buffer; FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, // Format flags NULL, // Location of the message code, // Error code MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), // Language (LPTSTR) &buffer, // Message buffer 0, // Buffer size NULL); // Arguments /* Print the message */ fprintf(stderr, "%s: failed with code %d: %s\n", name, errno, buffer); fflush(stderr); LocalFree(buffer); } static void print_error(const char *name) { print_error_code(name, GetLastError()); } /* * Check if a string contains spaces, and return the * number of extra characters. */ static int string_escape_length(const char *strp) { int c, escaped, extra; /* Empty arguments must be quoted too */ if(*strp == 0) return 2; /* Check for special characters */ extra = 0; escaped = 0; while((c = *strp++) != NULL) { switch(c) { case '"': escaped++; extra++; break; case '*': case '?': case '[': case ']': case '{': case '}': case '~': case '\'': escaped++; break; default: if(c <= ' ') escaped++; break; } } return escaped ? extra + 2 : 0; } /* * Quote the string while copying. */ static void string_copy_escaped(char *dstp, const char *srcp) { char c; *dstp++ = '"'; while((c = *srcp) != NULL) { if(c == '"') *dstp++ = '\\'; *dstp++ = c; srcp++; } *dstp++ = '"'; } /* * List all the threads in a process. * This may be slightly out-of-date because of the * delay from taking the snapshot. */ static int list_process_threads(DWORD pid, DWORD *threads, int limit) { THREADENTRY32 entry; HANDLE handle; int index; /* Take a snapshot of all running threads */ handle = CompatCreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0); if(handle == INVALID_HANDLE_VALUE) return 0; /* * Retrieve information about the first thread, * and exit if unsuccessful. */ entry.dwSize = sizeof(THREADENTRY32); if(CompatThread32First(handle, &entry) == FALSE) { CloseHandle(handle); return 0; } /* * Now walk the thread list of the system, * and display information about each thread * associated with the specified process. */ index = 0; do { if(entry.th32OwnerProcessID == pid) threads[index++] = entry.th32ThreadID; } while(CompatThread32Next(handle, &entry) && index < limit); CloseHandle(handle); return index; } /* * Suspend all the threads in the process. */ static int suspend_process(Process *processp) { DWORD threads[MAX_THREAD_COUNT]; HANDLE handle; int i, count; #ifdef OSH_DEBUG fprintf(stderr, "suspend_process\n"); fflush(stderr); #endif /* Not available before WindowsXP */ if(ExistsOpenThread() == 0) { fprintf(stderr, "Process control is not supported\n"); fflush(stderr); return -1; } /* Don't do anything if already suspended */ if(processp->status != STATUS_RUNNING) return 0; /* If it is a thread, suspend it */ if(processp->is_thread) { handle = CompatOpenThread(THREAD_SUSPEND_RESUME, FALSE, processp->thread); if(handle != INVALID_HANDLE_VALUE) { SuspendThread(handle); CloseHandle(handle); processp->changed = 1; processp->status = STATUS_STOPPED; SetEvent(state->changed); } return 0; } /* Otherwise it is a process; suspend all the subthreads */ if(processp->wid == 0) return -1; /* Enumerate all threads for that process */ count = list_process_threads(processp->wid, threads, MAX_THREAD_COUNT); #ifdef OSH_DEBUG fprintf(stderr, "suspend_process: suspend %d threads\n", count); fflush(stderr); #endif /* Suspend them all */ for(i = 0; i != count; i++) { handle = CompatOpenThread(THREAD_SUSPEND_RESUME, FALSE, threads[i]); if(handle == INVALID_HANDLE_VALUE) print_error("OpenThread"); if(handle != INVALID_HANDLE_VALUE) { if(SuspendThread(handle) < 0) print_error("SuspendThread"); CloseHandle(handle); } } /* Notify the wait handler */ processp->changed = 1; processp->status = STATUS_STOPPED; SetEvent(state->changed); return 0; } /* * Resume all the threads in the process. */ static int resume_process(Process *processp) { DWORD threads[MAX_THREAD_COUNT]; HANDLE handle; int i, count; /* Not available before WindowsXP */ if(ExistsOpenThread() == 0) { fprintf(stderr, "Process control is not supported\n"); fflush(stderr); return -1; } /* Don't do anything if already suspended */ if(processp->status != STATUS_STOPPED) return 0; #ifdef OSH_DEBUG fprintf(stderr, "resume_process: pid %i, wid %i\n", processp->pid, processp->wid); fflush(stderr); #endif /* If it is a thread, resume it */ if(processp->is_thread) { handle = CompatOpenThread(THREAD_SUSPEND_RESUME, FALSE, processp->thread); if(handle != INVALID_HANDLE_VALUE) { ResumeThread(handle); CloseHandle(handle); processp->status = STATUS_RUNNING; SetEvent(state->changed); } return 0; } /* Get the process id */ if(processp->wid == 0) return -1; /* Enumerate all threads for that process */ count = list_process_threads(processp->wid, threads, MAX_THREAD_COUNT); /* Suspend them all */ for(i = 0; i != count; i++) { handle = CompatOpenThread(THREAD_SUSPEND_RESUME, FALSE, threads[i]); if(handle != INVALID_HANDLE_VALUE) { ResumeThread(handle); CloseHandle(handle); } } processp->status = STATUS_RUNNING; return 0; } /* * Terminate the process. * Try to do this by sending the CTRL_C event. * If that fails, just terminate it. */ static int kill_process(Process *processp) { /* * Set the killed flag. * For threads, this will generate an exception * then next time it calls check_thread. */ processp->killed = 1; if(processp->is_thread) return 0; /* Get the process id */ if(processp->wid == 0) return -1; #if 0 /* Resume it so it can handle the exception */ GenerateConsoleCtrlEvent(CTRL_C_EVENT, processp->wid); resume_process(processp); #endif /* A lot of processes ignore the CTRL_C_EVENT, so just temrinate it */ TerminateProcess(processp->handle, 1); return 0; } /* * The generic handler. */ static int process_group_map(int (*op)(Process *processp), int pgrp) { Process *processp; int code; code = -1; for(processp = state->processes; processp; processp = processp->next) { if(processp->pgrp == pgrp) { if(op(processp) == 0) code = 0; } } return code; } /* * Allocate a new process identifier. * Make sure it isn't in use as a id or a group. */ static int alloc_pid(void) { Process *processp; int pid; do { /* Get the next candidate */ if(state->pid_counter == MAX_PID) state->pid_counter = 0; pid = ++state->pid_counter; /* Check that it isn't used */ for(processp = state->processes; processp; processp = processp->next) { if(processp->pid == pid || processp->pgrp == pid) break; } } while(processp); return pid; } /* * Terminate all jobs and exit. */ static void terminate_processes(void) { Process *processp; int wait; /* Send all processes the termination signal */ wait = 0; processp = state->processes; while(processp) { if(processp->pid != INIT_PID) { processp->killed = 1; if((processp->wid) && (processp->pid != INIT_PID)) { #ifdef OSH_DEBUG fprintf(stderr, "terminate_processes: Generating CTRL-C for process pid %i, group, status %i, is_thread %i, wid %i, \n", processp->pid, processp->pgrp, processp->status, processp->is_thread, processp->wid); fflush(stderr); #endif GenerateConsoleCtrlEvent(CTRL_C_EVENT, processp->wid); wait++; } resume_process(processp); } processp = processp->next; } /* Wait for them to die */ if(wait) { Sleep(1000); processp = state->processes; while(processp) { if((processp->wid) && (processp->pid != INIT_PID)) { #ifdef OSH_DEBUG fprintf(stderr, "terminate_processes: terminating process pid %i, wid %i\n", processp->pid, processp->wid); fflush(stderr); #endif TerminateProcess(processp->handle, 1); } processp = processp->next; } } } /************************************************************************ * OCaml interface. */ /* * Switch the preprocessor to send input to * the specified group. */ value omake_shell_sys_set_tty_pgrp(value v_pgrp) { CAMLparam1(v_pgrp); int pgrp; #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_set_tty_pgrp\n"); fflush(stderr); #endif pgrp = Int_val(v_pgrp); if(pgrp == 0) pgrp = INIT_PID; state->current_pgrp = pgrp; CAMLreturn(Val_unit); } /* * Process control. */ value omake_shell_sys_suspend(value v_pgrp) { CAMLparam1(v_pgrp); #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_suspend\n"); fflush(stderr); #endif if(process_group_map(suspend_process, Int_val(v_pgrp)) < 0) caml_failwith("omake_shell_sys_suspend"); CAMLreturn(Val_unit); } value omake_shell_sys_resume(value v_pgrp) { CAMLparam1(v_pgrp); #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_resume\n"); fflush(stderr); #endif if(process_group_map(resume_process, Int_val(v_pgrp)) < 0) caml_failwith("omake_shell_sys_resume"); CAMLreturn(Val_unit); } value omake_shell_sys_kill(value v_pgrp) { CAMLparam1(v_pgrp); #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_kill\n"); fflush(stderr); #endif if(process_group_map(kill_process, Int_val(v_pgrp)) < 0) caml_failwith("omake_shell_sys_kill"); CAMLreturn(Val_unit); } /* * Create a thread process. We don't fill in the thread id * yet (because we don't know what it is). */ value omake_shell_sys_create_thread_pid(value v_pgrp) { CAMLparam1(v_pgrp); Process *processp; HANDLE event; int pgrp; int pid; pid = alloc_pid(); #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_create_thread_pid: %d\n", pid); fflush(stderr); #endif /* Allocate the process data */ processp = (Process *) malloc(sizeof(Process)); if(processp == 0) caml_failwith("omake_shell_sys_create_thread_pid: out of memory"); memset(processp, 0, sizeof(Process)); /* Create an event for waiting on the thread */ event = CreateEvent(NULL, FALSE, FALSE, NULL); if(event == NULL) { free(processp); caml_failwith("omake_shell_sys_create_thread_pid: can't create event"); } pgrp = Int_val(v_pgrp); if(pgrp == 0) pgrp = pid; processp->pid = pid; processp->pgrp = pgrp; processp->status = STATUS_RUNNING; processp->is_thread = 1; processp->handle = event; processp->wid = 0; processp->next = state->processes; state->processes = processp; CAMLreturn(Val_int(pid)); } /* * Thread prologue. */ value omake_shell_sys_init_thread_pid(value v_pid) { CAMLparam1(v_pid); Process *processp; int pid; #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_init_thread_pid\n"); fflush(stderr); #endif /* Find the process */ pid = Int_val(v_pid); for(processp = state->processes; processp; processp = processp->next) { if(processp->pid == pid) break; } if(processp == 0) caml_raise_not_found(); /* Process has terminated */ processp->thread = GetCurrentThreadId(); CAMLreturn(Val_unit); } /* * Release the thread when it terminates. * Don't release the process struct yet, * just mark it as changed. */ value omake_shell_sys_release_thread_pid(value v_pid, value v_code) { CAMLparam2(v_pid, v_code); Process *processp; int pid; pid = Int_val(v_pid); #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_release_thread_pid: %d\n", pid); fflush(stderr); #endif /* Find the process */ for(processp = state->processes; processp; processp = processp->next) { #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_release_thread_pid: comparing with pid = %d\n", processp->pid); fflush(stderr); #endif if(processp->pid == pid) break; } if(processp == 0) caml_raise_not_found(); /* Process has terminated */ processp->changed = 1; processp->status = STATUS_EXITED; processp->code = Int_val(v_code); SetEvent(processp->handle); #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_release_thread_pid: pid = %d\n", processp->pid); fflush(stderr); #endif CAMLreturn(Val_unit); } /* * Check if the thread has been killed. */ value omake_shell_sys_check_thread(value v_unit) { CAMLparam1(v_unit); Process *processp; DWORD id; #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_check_thread\n"); fflush(stderr); #endif /* Find the process */ id = GetCurrentThreadId(); for(processp = state->processes; processp; processp = processp->next) { if(processp->thread == id) break; } if(processp == 0) CAMLreturn(Val_int(0)); CAMLreturn(Val_int(processp->killed)); } /* * Wait for any of the processes in the group to complete. * There are several modes: * pgrp == 0: wait for any process group leader * pgrp <> 0: wait for a specific process group * leader: if true, wait only for the group leader * if false, wait only for the children * nohang: if true, don't block * * JYH: this code has caused trouble with bogus exit codes * and memory corruption. For safety: * - Return a triple of results, as (bool * int * int), * not a (int * Unix.process_status). * - Perform all allocated within this function, * hence the gotos. */ value omake_shell_sys_wait(value v_pgrp, value v_leader, value v_nohang) { CAMLparam3(v_pgrp, v_leader, v_nohang); CAMLlocal1(tuple); int processes[MAXIMUM_WAIT_OBJECTS]; HANDLE handles[MAXIMUM_WAIT_OBJECTS]; Process **processpp, *processp; int ncount, code, pid, pgrp, leader; DWORD exitcode, timeout, index; #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_wait\n"); fflush(stderr); #endif /* Parameters */ pgrp = Int_val(v_pgrp); leader = Int_val(v_leader); timeout = Int_val(v_nohang) ? 0 : INFINITE; restart: /* Collect the processes and their handles */ ncount = 1; handles[0] = state->changed; for(processpp = &state->processes; processp = *processpp; (processpp = &(*processpp)->next) != NULL) { if((pgrp && processp->pgrp != pgrp) || (pgrp == 0 && processp->pgrp == INIT_PID) || (leader && processp->pid != processp->pgrp) || (leader == 0 && processp->pid == processp->pgrp)) { continue; } else if(processp->changed) goto done; else { if(ncount == MAXIMUM_WAIT_OBJECTS) caml_invalid_argument("omake_shell_sys_wait: too many processes"); processes[ncount] = processp->pid; handles[ncount] = processp->handle; ncount++; } } #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_wait: waiting for %d events\n", ncount); fprintf(stderr, "\tpgrp = %d, leader = %d, timeout = %d\n", pgrp, leader, timeout); fflush(stderr); #endif /* Wait for an event */ while(1) { /* Perform the wait */ caml_enter_blocking_section(); index = WaitForMultipleObjects(ncount, handles, FALSE, timeout); if(index == WAIT_FAILED) code = GetLastError(); caml_leave_blocking_section(); /* See if something has changed */ if(index == WAIT_OBJECT_0) { for(processpp = &state->processes; processp = *processpp; (processpp = &(*processpp)->next) != NULL) { if(processp->pgrp == pgrp && processp->changed) goto done; } } else break; } /* Get the index of the event */ if(index >= WAIT_OBJECT_0 + 1 && index < WAIT_OBJECT_0 + ncount) index -= WAIT_OBJECT_0; else if(index >= WAIT_ABANDONED_0 + 1 && index < WAIT_ABANDONED_0 + ncount) index -= WAIT_ABANDONED_0; else caml_raise_not_found(); /* Adjust process */ pid = processes[index]; for(processpp = &state->processes; processp = *processpp; (processpp = &(*processpp)->next) != NULL) { if(processp->pid == pid) break; } /* If the process is not found, some other thread waited for it */ if(processp == 0) goto restart; /* Otherwise, handle the wait */ processp->changed = 1; processp->status = STATUS_EXITED; /* Get the return code */ if(processp->is_thread == 0) { if(GetExitCodeProcess(handles[index], &exitcode) == FALSE) exitcode = 111; else if(exitcode == STILL_ACTIVE) goto restart; processp->code = exitcode; } /* * processpp points to the process that successfully exited. * Build the result as * bool * pid * exitcode * bool is true iff exited */ done: processp = *processpp; processp->changed = 0; #ifdef OSH_DEBUG fprintf(stderr, "+++ wait: pid=%d, group=%d, status=%d\n", processp->pid, processp->pgrp, processp->status); #endif tuple = caml_alloc_small(3, 0); Field(tuple, 1) = Val_int(processp->pid); Field(tuple, 2) = Val_int(processp->code); switch(processp->status) { case STATUS_STOPPED: Field(tuple, 0) = Val_false; break; case STATUS_EXITED: Field(tuple, 0) = Val_true; CloseHandle(processp->handle); *processpp = processp->next; free(processp); break; case STATUS_RUNNING: default: caml_invalid_argument("wait_process: process is running"); break; } CAMLreturn(tuple); } /* * Create a process. * * The process may have a new environment, * and its own directory. */ value omake_shell_sys_create_process(value v_info) { CAMLparam1(v_info); CAMLlocal2(v_envp, v_argvp); STARTUPINFO startup; PROCESS_INFORMATION process; char env[SIZEOF_ENVIRONMENT]; char argv[SIZEOF_COMMAND]; char *strp, *argp, *dir, *command; int i, white, count, index, length, creation_flags, status, pid, pgrp; Process *processp; #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_create_process\n"); fflush(stderr); #endif /* Allocate a new pid */ pid = alloc_pid(); pgrp = Int_val(Field(v_info, CREATE_PROCESS_PGRP)); if(pgrp == 0) pgrp = pid; /* Collect the environment */ v_envp = Field(v_info, CREATE_PROCESS_ENV); count = Wosize_val(v_envp); index = 0; env[1] = 0; for(i = 0; i != count; i++) { strp = String_val(Field(v_envp, i)); length = strlen(strp); if(index + length + 2 > SIZEOF_ENVIRONMENT) caml_failwith("omake_shell_sys_create_process: environment is too big"); strcpy(env + index, strp); index += length + 1; } env[index] = 0; /* Collect the arguments */ command = String_val(Field(v_info, CREATE_PROCESS_EXE)); v_argvp = Field(v_info, CREATE_PROCESS_ARGV); count = Wosize_val(v_argvp); if(count == 0) caml_invalid_argument("omake_shell_sys_create_process: command line is empty"); index = 0; for(i = 0; i != count; i++) { /* Win32 doesn't deal well when the command name differs from the executable */ if(i == 0) argp = command; else argp = String_val(Field(v_argvp, i)); length = strlen(argp); white = string_escape_length(argp); if(index + length + white + 4 >= SIZEOF_COMMAND) caml_failwith("omake_shell_sys_create_process: command line is too long"); if(index) argv[index++] = ' '; if(white) string_copy_escaped(argv + index, argp); else strcpy(argv + index, argp); index += length + white; } argv[index++] = 0; #if 0 fprintf(stderr, "Command: %s\n", argv); fflush(stderr); #endif /* Get the directory */ dir = String_val(Field(v_info, CREATE_PROCESS_DIR)); /* Provide redirection */ GetStartupInfo(&startup); startup.dwFlags |= STARTF_USESTDHANDLES; startup.hStdInput = Handle_val(Field(v_info, CREATE_PROCESS_STDIN)); startup.hStdOutput = Handle_val(Field(v_info, CREATE_PROCESS_STDOUT)); startup.hStdError = Handle_val(Field(v_info, CREATE_PROCESS_STDERR)); startup.lpReserved = NULL; startup.lpReserved2 = NULL; startup.cbReserved2 = 0; /* Do not give it the console */ creation_flags = CREATE_NEW_PROCESS_GROUP; #ifdef OSH_DEBUG fprintf(stderr, "creating process %d:\n", pid); fprintf(stderr, "\tcommand: %s\n", command); fprintf(stderr, "\tcommand line: %s\n", argv); /* * XXX - For some reason, I get the * "unresolved external symbol __imp__CommandLineToArgvW@8" * here. * * Aleksey * { LPWSTR *args; int argc, i; args = CommandLineToArgvW((LPCWSTR) argv, &argc); if (args) { fprintf(stderr, "\targv:\n"); for(i = 0; i < argc; i++) fprintf(stderr, "\t\t%ls\n", args[i]); } } */ fflush(stderr); #endif /* Create the process */ status = CreateProcess(command, // Application name argv, // Command line NULL, // Process attributes NULL, // Thread attributes TRUE, // Inherit handles creation_flags, // Creation flags env, // Environment dir, // Current directory &startup, // Startup info &process); // Process info if(status == FALSE) { char * lpMsgBuf = NULL; int bufLen = FormatMessageA( FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, GetLastError(), MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), // Default language (LPTSTR) &lpMsgBuf, 0, NULL ); #ifdef OSH_DEBUG print_error("CreateProcess"); fprintf(stderr, "Command: %s\n", command); fflush(stderr); #endif if ((bufLen < 1) || (bufLen > 1024)) { if (lpMsgBuf != NULL) LocalFree( lpMsgBuf ); caml_failwith("omake_shell_sys_create_process: process creation failed"); } else { char err[2048]; sprintf(err, "omake_shell_sys_create_process: process creation failed: %s", (char *)lpMsgBuf); if (lpMsgBuf != NULL) LocalFree( lpMsgBuf ); caml_failwith(err); } } CloseHandle(process.hThread); /* Allocate a new process struct */ processp = (Process *) malloc(sizeof(Process)); if(processp == 0) { CloseHandle(process.hProcess); caml_failwith("omake_shell_sys_create_process: out of memory"); } memset(processp, 0, sizeof(Process)); processp->pid = pid; processp->pgrp = pgrp; processp->status = STATUS_RUNNING; processp->handle = process.hProcess; processp->wid = process.dwProcessId; processp->next = state->processes; state->processes = processp; CAMLreturn(Val_int(pid)); } /************************************************************************ * Initialization. */ /* * The control handler. * CTRL-C: signal the current process group. * CTRL-BREAK: stop the current process group. * default: abort the foreground and stopped processes, and exit */ static BOOL WINAPI console_ctrl_handler(DWORD code) { BOOL rval; #ifdef OSH_DEBUG fprintf(stderr, "console_ctrl_handler\n"); fflush(stderr); #endif rval = TRUE; switch(code) { case CTRL_C_EVENT: if(state->current_pgrp != INIT_PID) { #ifdef OSH_DEBUG fprintf(stderr, "console_ctrl_handler: ctrl-c, pgrp=%d, state = 0x%08x\n", state->current_pgrp, (unsigned long) state); fflush(stderr); #endif process_group_map(suspend_process, state->current_pgrp); } break; case CTRL_BREAK_EVENT: /* Ignore CTRL+BREAK, but it will get passed to all children... */ if(state->current_pgrp != INIT_PID) process_group_map(suspend_process, state->current_pgrp); break; case CTRL_CLOSE_EVENT: case CTRL_LOGOFF_EVENT: case CTRL_SHUTDOWN_EVENT: fprintf(stderr, "Exiting\n"); fflush(stderr); terminate_processes(); /* Now we exit too */ ExitProcess(1); break; default: fprintf(stderr, "console_ctrl_handler: unknown code: %u\n", code); fflush(stderr); rval = FALSE; break; } #ifdef OSH_DEBUG fprintf(stderr, "console_ctrl_handler: returning %d\n", rval); fflush(stderr); #endif return rval; } /* * Create the shell struct. * We try to get a handle on the console, * but don't stress if it doesn't exist. */ value omake_shell_sys_init(value v_unit) { CAMLparam1(v_unit); Process *processp; HANDLE c_stdin; DWORD mode; int status; #ifdef OSH_DEBUG fprintf(stderr, "omake_shell_sys_init\n"); fflush(stderr); #endif if (state) /* Init was already called before */ CAMLreturn(Val_unit); /* Allocate a struct for the current process */ processp = (Process *) malloc(sizeof(Process)); if(processp == 0) caml_failwith("Omake_shell_csys.create_state: out of memory"); memset(processp, 0, sizeof(Process)); /* Allocate the state */ state = (ShellState *) malloc(sizeof(ShellState)); if(state == 0) caml_failwith("Omake_shell_csys.create_state: out of memory"); memset(state, 0, sizeof(ShellState)); state->pid_counter = INIT_PID; state->changed = CreateEvent(NULL, FALSE, FALSE, NULL); state->current_pgrp = INIT_PID; /* Initialize this process */ processp->pid = INIT_PID; processp->pgrp = INIT_PID; processp->status = STATUS_RUNNING; processp->handle = GetCurrentProcess(); processp->wid = GetCurrentProcessId(); state->processes = processp; /* Try to get the console */ c_stdin = GetStdHandle(STD_INPUT_HANDLE); if(c_stdin == INVALID_HANDLE_VALUE) CAMLreturn(Val_unit); status = GetConsoleMode(c_stdin, &mode); if(status) state->console = c_stdin; /* Install the console control handler */ SetConsoleCtrlHandler(console_ctrl_handler, TRUE); CAMLreturn(Val_unit); } /* * Stop everything. */ value omake_shell_sys_close(value v_unit) { CAMLparam1(v_unit); terminate_processes(); CAMLreturn(Val_unit); } #else /* WIN32 */ #include #include /* * Unix needs very few functions. */ value omake_shell_sys_set_tty_pgrp(value v_pgrp) { pid_t pgrp; pgrp = Int_val(v_pgrp); if(pgrp == 0) pgrp = getpgrp(); if(tcsetpgrp(0, pgrp) < 0) perror("tcsetpgrp"); return Val_unit; } value omake_shell_sys_setpgid(value v_pid, value v_pgrp) { pid_t pid, pgrp; pid = Int_val(v_pid); pgrp = Int_val(v_pgrp); if(setpgid(pid, pgrp) < 0) perror("setpgid"); return Val_unit; } #endif /* !WIN32 */ omake-0.10.3/src/clib/lm_compat_win32.c0000644000175000017500000001153613177364666016205 0ustar gerdgerd/* * Compatibility functions for the various versions of Win32. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] */ #include #include #include #include #include #include #ifdef WIN32 /* Disable some of the warnings */ #pragma warning( disable : 4100 4201 ) #include #include #include #include "lm_compat_win32.h" /* * Pointers to the functions. */ static HANDLE (__stdcall *OpenThreadF)(DWORD, BOOL, DWORD); static BOOL (__stdcall *GetLongPathNameF)(LPCTSTR, LPTSTR, DWORD); static HANDLE (__stdcall *CreateToolhelp32SnapshotF)(DWORD, DWORD); static BOOL (__stdcall *Thread32FirstF)(HANDLE, LPTHREADENTRY32); static BOOL (__stdcall *Thread32NextF)(HANDLE, LPTHREADENTRY32); static HRESULT (__stdcall *SHGetFolderPathF)(HWND, int, HANDLE, DWORD, LPTSTR); static BOOL (__stdcall *SHGetSpecialFolderPathF)(HWND, LPTSTR, int, BOOL); /* * Compatibility. */ int ExistsOpenThread(void) { return OpenThreadF ? 1 : 0; } HANDLE CompatOpenThread(DWORD arg1, BOOL arg2, DWORD arg3) { return OpenThreadF(arg1, arg2, arg3); } BOOL CompatGetLongPathName(LPCTSTR arg1, LPTSTR arg2, DWORD arg3) { BOOL b = 0; if(GetLongPathNameF) b = GetLongPathNameF(arg1, arg2, arg3); return b; } HANDLE CompatCreateToolhelp32Snapshot(DWORD arg1, DWORD arg2) { return CreateToolhelp32SnapshotF(arg1, arg2); } BOOL CompatThread32First(HANDLE arg1, LPTHREADENTRY32 arg2) { return Thread32FirstF(arg1, arg2); } BOOL CompatThread32Next(HANDLE arg1, LPTHREADENTRY32 arg2) { return Thread32NextF(arg1, arg2); } HRESULT CompatSHGetFolderPath(HWND hwndOwner, int nFolder, HANDLE hToken, DWORD dwFlags, LPTSTR pszPath) { if(SHGetFolderPathF) return SHGetFolderPathF(hwndOwner, nFolder, hToken, dwFlags, pszPath); else if(SHGetSpecialFolderPathF) { BOOL fCreate = nFolder & CSIDL_FLAG_CREATE ? TRUE : FALSE; nFolder &= ~CSIDL_FLAG_CREATE; fCreate = SHGetSpecialFolderPathF(hwndOwner, pszPath, nFolder, fCreate); return fCreate ? S_OK : E_FAIL; } else return E_NOTIMPL; } /* * Decide whether OpenThread is available. */ static void init(void) { HINSTANCE hinst; hinst = LoadLibrary(TEXT("KERNEL32")); if(hinst != NULL) { *(FARPROC *)&OpenThreadF = GetProcAddress(hinst, "OpenThread"); #ifdef UNICODE *(FARPROC *)&GetLongPathNameF = GetProcAddress(hinst, "GetLongPathNameW"); #else *(FARPROC *)&GetLongPathNameF = GetProcAddress(hinst, "GetLongPathNameA"); #endif *(FARPROC *)&CreateToolhelp32SnapshotF = GetProcAddress(hinst, "CreateToolhelp32Snapshot"); *(FARPROC *)&Thread32FirstF = GetProcAddress(hinst, "Thread32First"); *(FARPROC *)&Thread32NextF = GetProcAddress(hinst, "Thread32Next"); } hinst = LoadLibrary(TEXT("SHELL32")); if(hinst != NULL) { #ifdef UNICODE *(FARPROC *)&SHGetFolderPathF = GetProcAddress(hinst, "SHGetFolderPathW"); *(FARPROC *)&SHGetSpecialFolderPathF = GetProcAddress(hinst, "SHGetSpecialFolderPathW"); #else *(FARPROC *)&SHGetFolderPathF = GetProcAddress(hinst, "SHGetFolderPathA"); *(FARPROC *)&SHGetSpecialFolderPathF = GetProcAddress(hinst, "SHGetSpecialFolderPathA"); #endif } if(SHGetFolderPathF == 0) { hinst = LoadLibrary(TEXT("SHFOLDER")); if(hinst != NULL) { #ifdef UNICODE *(FARPROC *)&SHGetFolderPathF = GetProcAddress(hinst, "SHGetFolderPathW"); #else *(FARPROC *)&SHGetFolderPathF = GetProcAddress(hinst, "SHGetFolderPathA"); #endif } } } /* * ML interface. */ value lm_compat_init(value v_unit) { init(); return Val_unit; } #else /* !WIN32 */ value lm_compat_init(value v_unit) { return Val_unit; } #endif /* !WIN32 */ omake-0.10.3/src/clib/omake_shell_spawn.c0000644000175000017500000006113513177364666016703 0ustar gerdgerd/* This is the module for subprocess execution derived from OCamlnet. It is only meant for Unix. If available, it takes advantage from the posix_spawn call. Copyright (C) 2014 by Gerd Stolpmann This file is licensed under the same conditions as omake. This work was sponsored by Lexifi. */ #define _GNU_SOURCE /* we need that to make the POSIX_SPAWN_USEVFORK macro visible under Linux */ #include "caml/misc.h" #include "caml/mlvalues.h" #include "caml/alloc.h" #include "caml/memory.h" #include "caml/fail.h" #include "caml/signals.h" #include "caml/unixsupport.h" #include #include #include #include #ifndef WIN32 #include #include #include #include #include #endif #ifdef HAVE_POSIX_SPAWN #include #endif /* needed from caml/signals.h */ CAMLextern int caml_convert_signal_number (int); /* This version here is a bit simplified compared with the OCamlnet version. In particular, we can assume that we are single-threaded. */ /**********************************************************************/ /* spawn */ /**********************************************************************/ static void empty_signal_handler(int sig) {} typedef union { char buffer[256]; struct { int b_errno; char b_function[64]; } decoded; } marshalled_error; #define MAIN_ERROR(e,f) { uerror_errno = e; uerror_function = f; goto main_exit; } #define SUB_ERROR(e,f) { uerror_errno = e; uerror_function = f; goto sub_error; } /* Note: In the following function we can assume that we are not on Win32. Hence, file descriptors are simply ints. */ /* omake_shell_spawn_spawn_nat is the full-featured version using fork/exec */ CAMLprim value omake_shell_spawn_compat_nat(value v_chdir, value v_pg, value v_fd_actions, value v_sig_actions, value v_env, value v_cmd, value v_args) { #ifndef WIN32 int uerror_errno; char *uerror_function; value return_value; int code; sigset_t mask; sigset_t save_mask; sigset_t spawn_mask; int cleanup_mask; int ctrl_pipe[2]; int cleanup_pipe0; int cleanup_pipe1; int cleanup_bsection; pid_t pid; char **sub_argv; char **sub_env; int cleanup_sub_argv; int cleanup_sub_env;; marshalled_error me; ssize_t n; char *ttyname; int ttyfd; struct sigaction sigact; int signr; value v_sig_actions_l; value v_sig_actions_hd; value v_fd_actions_l; value v_fd_actions_hd; value v_fd_actions_0; value v_signals_l; value v_signals_hd; int j, k, nofile; int fd1, fd2; uerror_errno = 0; cleanup_mask = 0; cleanup_pipe0 = 0; cleanup_pipe1 = 0; cleanup_bsection = 0; cleanup_sub_argv = 0; cleanup_sub_env = 0; sub_argv = NULL; sub_env = NULL; return_value = Val_int(0); uerror_function = ""; nofile = sysconf(_SC_OPEN_MAX); /* First thing is that we have to block all signals. In a multi-threaded program this is only done for the thread calling us, otherwise for the whole process. [fork] will reset all pending signals, so we can be sure the subprocess won't get any signals until we perform the signal actions in the subprocess. In the calling process, the mask is reset below at [exit]. */ code = sigfillset(&mask); if (code == -1) unix_error(EINVAL, "Omake_shell_spawn/sigfillset [000]", Nothing); code = sigprocmask(SIG_SETMASK, &mask, &save_mask); if (code == -1) uerror("Omake_shell_spawn/sigprocmask [002]", Nothing); memcpy(&spawn_mask, &save_mask, sizeof(sigset_t)); /* From now on, we don't jump out with uerror, but leave via "exit" below. */ cleanup_mask = 1; /* Create the control pipe for reporting errors. */ code = pipe(ctrl_pipe); if (code == -1) MAIN_ERROR(errno, "Omake_shell_spawn/pipe [010]"); cleanup_pipe0 = 1; cleanup_pipe1 = 1; /* Prepare sub_argv and sub_env: */ sub_argv = malloc((Wosize_val(v_args) + 1) * sizeof(char *)); if (sub_argv == NULL) MAIN_ERROR(ENOMEM, "Omake_shell_spawn/malloc [020]"); for (k = 0; k < Wosize_val(v_args); k++) { sub_argv[k] = String_val(Field(v_args, k)); } sub_argv[ Wosize_val(v_args)] = NULL; cleanup_sub_argv = 1; sub_env = malloc((Wosize_val(v_env) + 1) * sizeof(char *)); if (sub_env == NULL) MAIN_ERROR(ENOMEM, "Omake_shell_spawn/malloc [021]"); for (k = 0; k < Wosize_val(v_env); k++) { sub_env[k] = String_val(Field(v_env, k)); } sub_env[ Wosize_val(v_env)] = NULL; cleanup_sub_env = 1; /* Because fork() can be slow we allow here that other threads can run */ /* caml_enter_blocking_section(); cleanup_bsection = 1; -- TODO: check this more carefully before enabling it -- see also leave_blocking_section below */ /* Fork the process. */ pid = fork(); if (pid == (pid_t) -1) MAIN_ERROR(errno, "Omake_shell_spawn/fork [031]"); if (pid != (pid_t) 0) goto main_process; /*sub_process:*/ /* The start of the sub process. */ pid = getpid(); /* Close the read side of the control pipe. Set the close-on-exec flag for the write side. */ code = close(ctrl_pipe[0]); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/close [100]"); code = fcntl(ctrl_pipe[1], F_SETFD, FD_CLOEXEC); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/fcntl [101]"); /* If required, change the working directory */ if (Is_block(v_chdir)) { switch(Tag_val(v_chdir)) { case 0: /* Wd_chdir */ code = chdir(String_val(Field(v_chdir, 0))); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/chdir [110]"); break; case 1: /* Wd_fchdir */ code = fchdir(Int_val(Field(v_chdir, 1))); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/fchdir [111]"); break; default: SUB_ERROR(EINVAL, "Omake_shell_spawn/assert_chdir [112]"); } } /* If required, create/join the process group */ if (Is_block(v_pg)) { /* Must be Pg_join_group */ code = setpgid(0, Int_val(Field(v_pg, 0))); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/setpgid [120]"); } else { switch (Int_val(v_pg)) { case 0: /* Pg_keep */ break; case 1: /* Pg_new_bg_group */ code = setpgid(0, 0); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/setpgid [130]"); break; case 2: /* Pg_new_fg_group */ code = setpgid(0, 0); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/setpgid [140]"); ttyname = ctermid(NULL); /* no error code defined! */ ttyfd = open(ttyname, O_RDWR); if (ttyfd == -1) SUB_ERROR(errno, "Omake_shell_spawn/open [141]"); /* tcsetpgrp may send a SIGTTOU signal to this process. We want to hide this signal, so we set this signal to be ignored. We do this by setting an empty signal handler. On exec, the SIGTTOU signal will be reset to the default action in this case - which is ok because the set of pending signals is also cleared. */ sigact.sa_sigaction = NULL; sigact.sa_handler = &empty_signal_handler; sigact.sa_flags = 0; code = sigemptyset(&(sigact.sa_mask)); if (code == -1) SUB_ERROR(EINVAL, "Omake_shell_spawn/sigemptyset [142]"); code = sigaction(SIGTTOU, &sigact, NULL); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/sigaction [143]"); code = tcsetpgrp(ttyfd, pid); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/tcsetpgrp [144]"); code = close(ttyfd); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/close [145]"); break; default: SUB_ERROR(EINVAL, "Omake_shell_spawn/assert_pg [160]"); } } /* do the signal stuff: */ v_sig_actions_l = v_sig_actions; while (Is_block(v_sig_actions_l)) { v_sig_actions_hd = Field(v_sig_actions_l, 0); v_sig_actions_l = Field(v_sig_actions_l, 1); switch(Tag_val(v_sig_actions_hd)) { case 0: /* Sig_default */ signr = caml_convert_signal_number (Int_val(Field(v_sig_actions_hd,0))); sigact.sa_sigaction = NULL; sigact.sa_handler = SIG_DFL; sigact.sa_flags = 0; code = sigemptyset(&(sigact.sa_mask)); if (code == -1) SUB_ERROR(EINVAL, "Omake_shell_spawn/sigemptyset [170]"); code = sigaction(signr, &sigact, NULL); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/sigaction [171]"); break; case 1: /* Sig_ignore */ signr = caml_convert_signal_number (Int_val(Field(v_sig_actions_hd,0))); sigact.sa_sigaction = NULL; sigact.sa_handler = SIG_IGN; sigact.sa_flags = 0; code = sigemptyset(&(sigact.sa_mask)); if (code == -1) SUB_ERROR(EINVAL, "Omake_shell_spawn/sigemptyset [180]"); code = sigaction(signr, &sigact, NULL); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/sigaction [181]"); break; case 2: /* Sig_mask */ sigemptyset(&spawn_mask); v_signals_l = Field(v_sig_actions_hd, 0); while (Is_block(v_signals_l)) { v_signals_hd = Field(v_signals_l, 0); v_signals_l = Field(v_signals_l, 1); signr = caml_convert_signal_number(Int_val(v_signals_hd)); code = sigaddset(&spawn_mask, signr); if (code == -1) SUB_ERROR(EINVAL, "Omake_shell_spawn/sigaddset [190]"); }; break; default: SUB_ERROR(EINVAL, "Omake_shell_spawn/assert_sig [199]"); } }; /* do the fd stuff: */ v_fd_actions_l = v_fd_actions; while (Is_block(v_fd_actions_l)) { v_fd_actions_hd = Field(v_fd_actions_l, 0); v_fd_actions_l = Field(v_fd_actions_l, 1); switch(Tag_val(v_fd_actions_hd)) { case 0: /* Fda_close */ fd1 = Int_val(Field(v_fd_actions_hd, 0)); if (fd1 == ctrl_pipe[1]) SUB_ERROR(EBADF, "Omake_shell_spawn/fda_close [200]"); code = close(fd1); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/close [201]"); break; case 1: /* Fda_close_ignore */ fd1 = Int_val(Field(v_fd_actions_hd, 0)); if (fd1 != ctrl_pipe[1]) { code = close(fd1); if (code == -1 && errno != EBADF) SUB_ERROR(errno, "Omake_shell_spawn/close [210]"); } /* ignore requests to close the ctrl_pipe, it's closed anyway later */ break; case 2: /* Fda_close_except */ v_fd_actions_0 = Field(v_fd_actions_hd, 0); j = Wosize_val(v_fd_actions_0); /* array length */ for (k=0; k=j || !Bool_val(Field(v_fd_actions_0,k))) { if (k != ctrl_pipe[1]) close(k); /* ignore any error */ } } break; case 3: /* Fda_dup2 */ fd1 = Int_val(Field(v_fd_actions_hd, 0)); fd2 = Int_val(Field(v_fd_actions_hd, 1)); /* If fd1 is the ctrl_pipe, return EBADF: */ if (fd1 == ctrl_pipe[1]) SUB_ERROR(EBADF, "Omake_shell_spawn/fda_dup2 [220]"); /* Check that fd1 is valid by reading the fd flags: */ code = fcntl(fd1, F_GETFD); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/fcntl [221]"); /* Be careful when fd2 is the ctrl_pipe: */ if (fd2 == ctrl_pipe[1]) { code = dup(ctrl_pipe[1]); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/dup [222]"); ctrl_pipe[1] = code; code = fcntl(ctrl_pipe[1], F_SETFD, FD_CLOEXEC); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/fcntl [223]"); } code = dup2(fd1, fd2); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/dup2 [224]"); /* The FD_CLOEXEC flag remains off for the duped descriptor */ break; default: SUB_ERROR(EINVAL, "Omake_shell_spawn/assert_fd [230]"); }; }; /* set the signal mask: */ code = sigprocmask(SIG_SETMASK, &spawn_mask, NULL); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/sigprocmask [241]"); /* exec the new program: */ code = execve(String_val(v_cmd), sub_argv, sub_env); if (code == -1) SUB_ERROR(errno, "Omake_shell_spawn/execve [290]"); SUB_ERROR(EINVAL, "Omake_shell_spawn/assert_execve [291]"); sub_error: /* Marshal the error in uerror_errno and uerror_function */ me.decoded.b_errno = uerror_errno; strcpy(me.decoded.b_function, uerror_function); n = write(ctrl_pipe[1], me.buffer, sizeof(me.buffer)); /* it doesn't make much sense here to check for write errors */ _exit(127); main_process: /* Here the main process continues after forking. There's not much to do here: We close the write side of the control pipe, so the read side can see EOF. We check then whether the read side is just closed (meaning no error), or whether there are bytes, the marshalled error condition. */ if (cleanup_bsection) { caml_leave_blocking_section(); cleanup_bsection = 0; }; code = close(ctrl_pipe[1]); if (code == -1) { uerror_errno = errno; uerror_function = "Omake_shell_spawn/close [300]"; goto main_exit; }; cleanup_pipe1 = 0; /* it's already closed */ n = read(ctrl_pipe[0], me.buffer, sizeof(me.buffer)); if (n == (ssize_t) -1) { uerror_errno = errno; uerror_function = "Omake_shell_spawn/read [301]"; goto main_exit; }; if (n == 0) { /* hey, we have success! */ return_value = Val_int(pid); goto main_exit; } /* There is an error message in me. Look at it. */ if (n != (ssize_t) sizeof(me.buffer)) { uerror_errno = EINVAL; uerror_function = "Omake_shell_spawn/assert_me [302]"; } /* Also don't forget to wait on the child to avoid zombies: */ code = 1; while (code) { code = waitpid(pid, NULL, 0); code = (code == -1 && errno == EINTR); }; uerror_errno = me.decoded.b_errno; uerror_function = me.decoded.b_function; /* now exit... */ main_exit: /* Policy: If we already have an error to report, and any of the cleanup actions also indicates an error, we return the first error to the caller. */ if (cleanup_bsection) caml_leave_blocking_section(); if (cleanup_mask) { code = sigprocmask(SIG_SETMASK, &save_mask, NULL); if (code == -1 && uerror_errno == 0) { uerror_errno = errno; uerror_function = "Omake_shell_spawn/sigprocmask [401]"; } }; if (cleanup_pipe0) { code = close(ctrl_pipe[0]); if (code == -1 && uerror_errno == 0) { uerror_errno = errno; uerror_function = "Omake_shell_spawn/close [410]"; } } if (cleanup_pipe1) { code = close(ctrl_pipe[1]); if (code == -1 && uerror_errno == 0) { uerror_errno = errno; uerror_function = "Omake_shell_spawn/close [411]"; } } if (cleanup_sub_argv) { free(sub_argv); } if (cleanup_sub_env) { free(sub_env); } if (uerror_errno != 0) unix_error(uerror_errno, uerror_function, Nothing); return return_value; #else invalid_argument("Omake_shell_spawn.compat_spawn"); #endif } CAMLprim value omake_shell_spawn_compat_byte(value * argv, int argn) { return omake_shell_spawn_compat_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); } CAMLprim value omake_shell_spawn_have_posix_spawn(value dummy) { #ifdef HAVE_POSIX_SPAWN return Val_bool(1); #else return Val_bool(0); #endif } CAMLprim value omake_shell_spawn_posix_nat(value v_pg, value v_fd_actions, value v_sig_actions, value v_env, value v_cmd, value v_args) { #ifdef HAVE_POSIX_SPAWN int uerror_errno; char *uerror_function; value return_value; int code; short flags; int use_fork_exec; pid_t pid; char **sub_argv; char **sub_env; int cleanup_sub_argv; int cleanup_sub_env;; posix_spawn_file_actions_t fd_actions; int n_fd_actions; posix_spawnattr_t attr; int cleanup_fd_actions; int cleanup_attr; value v_fd_actions_l; value v_fd_actions_hd; value v_fd_actions_0; int fd_known; int cleanup_fd_known; value v_sig_actions_l; value v_sig_actions_hd; value v_signals_l; value v_signals_hd; sigset_t sigdfl; sigset_t spawn_mask; int fd1, fd2; int signr; long j,k; long nofile; uerror_errno = 0; cleanup_sub_argv = 0; cleanup_sub_env = 0; cleanup_fd_actions = 0; cleanup_attr = 0; cleanup_fd_known = 0; sub_argv = NULL; sub_env = NULL; return_value = Val_int(0); uerror_function = ""; flags = 0; fd_known = 0; use_fork_exec = 0; nofile = sysconf(_SC_OPEN_MAX); /* Set fd_known to a valid file descriptor */ code = open(".", O_RDONLY, 0); if (code == -1) MAIN_ERROR(errno, "omake_shell_spawn_posix/open"); fd_known = code; cleanup_fd_known = 1; code = fcntl(fd_known, F_SETFD, FD_CLOEXEC); if (code == -1) MAIN_ERROR(errno, "omake_shell_spawn_posix/fcntl"); /* Prepare sub_argv and sub_env: */ sub_argv = malloc((Wosize_val(v_args) + 1) * sizeof(char *)); if (sub_argv == NULL) MAIN_ERROR(ENOMEM, "omake_shell_spawn_posix/malloc [1]"); for (k = 0; k < Wosize_val(v_args); k++) { sub_argv[k] = String_val(Field(v_args, k)); } sub_argv[ Wosize_val(v_args)] = NULL; cleanup_sub_argv = 1; sub_env = malloc((Wosize_val(v_env) + 1) * sizeof(char *)); if (sub_env == NULL) MAIN_ERROR(ENOMEM, "omake_shell_spawn_posix/malloc [2]"); for (k = 0; k < Wosize_val(v_env); k++) { sub_env[k] = String_val(Field(v_env, k)); } sub_env[ Wosize_val(v_env)] = NULL; cleanup_sub_env = 1; /* Init fd_actions */ code = posix_spawn_file_actions_init(&fd_actions); n_fd_actions = 0; if (code != 0) MAIN_ERROR(code, "omake_shell_spawn_posix/posix_spawn_file_actions_init"); cleanup_fd_actions = 1; code = posix_spawnattr_init(&attr); if (code != 0) MAIN_ERROR(code, "omake_shell_spawn_posix/posix_spawnattr_init"); cleanup_attr = 1; /* initialize the attributes */ /* If required, create/join the process group */ if (Is_block(v_pg)) { /* Must be Pg_join_group */ code = posix_spawnattr_setpgroup(&attr, Int_val(Field(v_pg, 0))); if (code != 0) MAIN_ERROR(errno, "omake_shell_spawn/psa_setpgroup [1]"); flags |= POSIX_SPAWN_SETPGROUP; } else { switch (Int_val(v_pg)) { case 0: /* Pg_keep */ break; case 1: /* Pg_new_bg_group */ code = posix_spawnattr_setpgroup(&attr, 0); if (code != 0) MAIN_ERROR(errno, "omake_shell_spawn/psa_setpgroup [2]"); flags |= POSIX_SPAWN_SETPGROUP; break; case 2: /* Pg_new_fg_group */ invalid_argument ("Omake_Shell_Spawn_posix.posix_spawn: Pg_new_fg_group not supported"); break; default: MAIN_ERROR(EINVAL, "omake_shell_spawn_posix/assert_pg"); } } /* do the signal stuff: */ sigemptyset(&sigdfl); sigemptyset(&spawn_mask); v_sig_actions_l = v_sig_actions; while (Is_block(v_sig_actions_l)) { v_sig_actions_hd = Field(v_sig_actions_l, 0); v_sig_actions_l = Field(v_sig_actions_l, 1); switch(Tag_val(v_sig_actions_hd)) { case 0: /* Sig_default */ signr = caml_convert_signal_number (Int_val(Field(v_sig_actions_hd,0))); code = sigaddset(&sigdfl, signr); if (code == -1) MAIN_ERROR(EINVAL,"omake_shell_spawn_posix/sigemptyset"); flags |= POSIX_SPAWN_SETSIGDEF; break; case 1: /* Sig_ignore */ invalid_argument ("Omake_Shell_Spawn_posix.posix_spawn: Sig_ignore not supported"); break; case 2: /* Sig_mask */ v_signals_l = Field(v_sig_actions_hd, 0); while (Is_block(v_signals_l)) { v_signals_hd = Field(v_signals_l, 0); v_signals_l = Field(v_signals_l, 1); signr = caml_convert_signal_number(Int_val(v_signals_hd)); code = sigaddset(&spawn_mask, signr); if (code == -1) MAIN_ERROR(errno, "omake_shell_spawn/sigaddset [190]"); }; flags |= POSIX_SPAWN_SETSIGMASK; break; default: MAIN_ERROR(EINVAL, "omake_shell_spawn_posix/assert_sig"); } }; code = posix_spawnattr_setsigdefault(&attr, &sigdfl); if (code != 0) MAIN_ERROR(code, "omake_shell_spawn_posix/psa_setsigdefault"); code = posix_spawnattr_setsigmask(&attr, &spawn_mask); if (code != 0) MAIN_ERROR(code, "omake_shell_spawn_posix/psa_setsigmask"); /* See http://sources.redhat.com/bugzilla/show_bug.cgi?id=378 This is Linux-specific. However, contrary to this discussion recent versions of glibc always use vfork. */ #ifdef POSIX_SPAWN_USEVFORK flags |= POSIX_SPAWN_USEVFORK; #endif code = posix_spawnattr_setflags(&attr, flags); if (code != 0) MAIN_ERROR(code, "omake_shell_spawn_posix/psa_setflags"); /* do the fd stuff: */ v_fd_actions_l = v_fd_actions; while (Is_block(v_fd_actions_l)) { v_fd_actions_hd = Field(v_fd_actions_l, 0); v_fd_actions_l = Field(v_fd_actions_l, 1); switch(Tag_val(v_fd_actions_hd)) { case 1: /* Fda_close_ignore */ /* We translate this into a dup2 + close */ fd1 = Int_val(Field(v_fd_actions_hd, 0)); if (fd1 != fd_known) { code = posix_spawn_file_actions_adddup2(&fd_actions, fd_known, fd1); if (code != 0) MAIN_ERROR(code, "omake_shell_spawn_posix/psfa_adddup2 [1]"); n_fd_actions++; code = posix_spawn_file_actions_addclose(&fd_actions, fd1); if (code != 0) MAIN_ERROR(code, "omake_shell_spawn_posix/psfa_addclose [2]"); n_fd_actions++; }; break; case 0: /* Fda_close */ fd1 = Int_val(Field(v_fd_actions_hd, 0)); if (fd1 != fd_known) { code = posix_spawn_file_actions_addclose(&fd_actions, fd1); if (code != 0) MAIN_ERROR(code, "omake_shell_spawn_posix/psfa_addclose [1]"); n_fd_actions++; }; break; case 2: /* Fda_close_except */ v_fd_actions_0 = Field(v_fd_actions_hd, 0); j = Wosize_val(v_fd_actions_0); /* array length */ for (k=0; k=j || !Bool_val(Field(v_fd_actions_0,k))) { if (k != fd_known) { code = posix_spawn_file_actions_adddup2 (&fd_actions, fd_known, k); if (code != 0) MAIN_ERROR (code, "omake_shell_spawn_posix/psfa_actions_adddup2 [2]"); n_fd_actions++; code = posix_spawn_file_actions_addclose (&fd_actions, k); if (code != 0) MAIN_ERROR (code, "omake_shell_spawn_posix/psfa_addclose [3]"); n_fd_actions++; } } } break; case 3: /* Fda_dup2 */ /* Ignore here fd_known - even if fd1 or fd2 is fd_known it will remain open, and that's all we need */ fd1 = Int_val(Field(v_fd_actions_hd, 0)); fd2 = Int_val(Field(v_fd_actions_hd, 1)); code = posix_spawn_file_actions_adddup2(&fd_actions, fd1, fd2); if (code != 0) MAIN_ERROR(code, "omake_shell_spawn_posix/psfa_actions_adddup2 [3]"); n_fd_actions++; break; default: MAIN_ERROR(EINVAL, "omake_shell_spawn_posix/assert_fd"); }; }; #ifdef __APPLE__ /* MacOS limits the number of file actions arbitrarily to the max number of open files. We catch this here, and cause a failure "USE_FORK_EXEC", so the alternate fork/exec-based spawn will be used instead. */ if (n_fd_actions > nofile) { use_fork_exec = 1; goto main_exit; }; #endif code = posix_spawn(&pid, String_val(v_cmd), &fd_actions, &attr, sub_argv, sub_env); if (code != 0) MAIN_ERROR(code, "omake_shell_spawn_posix/posix_spawn"); return_value = Val_int(pid); main_exit: /* Policy: If we already have an error to report, and any of the cleanup actions also indicates an error, we return the first error to the caller. */ if (cleanup_sub_argv) { free(sub_argv); } if (cleanup_sub_env) { free(sub_env); } if (cleanup_fd_known) { close(fd_known); }; if (cleanup_fd_actions) { posix_spawn_file_actions_destroy(&fd_actions); }; if (cleanup_attr) { posix_spawnattr_destroy(&attr); }; if (uerror_errno != 0) unix_error(uerror_errno, uerror_function, Nothing); if (use_fork_exec != 0) failwith("USE_FORK_EXEC"); return return_value; #else invalid_argument("Omake_shell_spawn.posix_spawn not available"); #endif } CAMLprim value omake_shell_spawn_posix_byte(value * argv, int argn) { return omake_shell_spawn_posix_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } CAMLprim value omake_shell_spawn_fchdir(value fd) { #ifndef WIN32 if (fchdir(Int_val(fd)) == -1) uerror("fchdir", Nothing); return Val_unit; #else invalid_argument("Omake_shell_spawn.fchdir not available"); #endif } omake-0.10.3/src/clib/lm_heap.c0000644000175000017500000001670713177364666014622 0ustar gerdgerd/* * Some debugging code for the heap. * WARNING: if you want to use this, you _must_ link against a DEBUG * version of OCaml! * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2006 Mojave group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] */ #include #include #include #include #include #include #if defined(WIN32) || defined(_WIN32) /* Disable some of the warnings */ #pragma warning( disable : 4146 ) #endif extern char *caml_young_start, *caml_young_ptr, *caml_young_limit, *caml_young_end; static char *null = 0; #undef abort #define abort() (*null = 0) static void search_pointer(char **pointers, char *name, unsigned bound, char *p, char *v, unsigned index) { unsigned i, j, k; char *p2; i = 0; j = bound; while(j - i > 1) { k = (i + j) >> 1; p2 = pointers[k]; if(p2 <= p) i = k; else j = k; } p2 = pointers[i]; if((p2 != p) && (Tag_val(p) != Infix_tag)) { fprintf(stderr, "%s: illegal pointer: 0x%08lx < 0x%08lx < 0x%08lx, size = %lud, tag = %d\n", name, (unsigned long) p2, (unsigned long) p, (unsigned long) pointers[i + 1], Wosize_val(p), Tag_val(p)); fprintf(stderr, "points into: 0x%08lx: index = %d, size = %lud, tag = %d\n", (unsigned long) p2, i, Wosize_val(p2), Tag_val(p2)); fprintf(stderr, "from block: 0x%08lx: size = %lud, tag = %d, field = %d\n", (unsigned long) v, Wosize_val(v), Tag_val(v), index); fflush(stderr); abort(); } } static void lm_heap_check_aux1(char *name) { /* char *start, *ptr, *end; */ char *v; value p, *next; mlsize_t size; unsigned i, index, found; char *pointers[1 << 16]; /* start = caml_young_start; */ /* ptr = caml_young_ptr; */ /* end = caml_young_end; */ fprintf(stderr, "AAA: %s: [0x%08lx, 0x%08lx, 0x%08lx, 0x%08lx] (%ld/%ld/%ld bytes)\n", name, (unsigned long) caml_young_start, (unsigned long) caml_young_ptr, (unsigned long) caml_young_limit, (unsigned long) caml_young_end, ((unsigned long) caml_young_end) - (unsigned long) caml_young_ptr, ((unsigned long) caml_young_end) - (unsigned long) caml_young_limit, ((unsigned long) caml_young_end) - (unsigned long) caml_young_start); fflush(stderr); /* * Phase 1: check that the headers have the right sizes. */ v = (char *) Val_hp(caml_young_ptr); index = 0; while(v < caml_young_end) { pointers[index++] = (char *) v; size = Wosize_val(v); fprintf(stderr, "%s: 0x%08lx: size %lud, tag = %d\n", name, (unsigned long) v, size, Tag_val(v)); found = 0; for(i = 0; i != 10; i++) { next = &Field(v, size + i); if(next < (value *) caml_young_end) { p = *next; #define Debug_free_minor 0xD700D6D7ul if(p == Debug_free_minor) { fprintf(stderr, "\tnext[%d]:0x%08lx = 0x%08lx\n", i, (unsigned long) next, (unsigned long) p); found = 1; } else if(found) fprintf(stderr, "\tnext[%d]:0x%08lx = 0x%08lx, size = %lud, tag = %d\n", i, (unsigned long) next, (unsigned long) p, Wosize_hd(p), Tag_hd(p)); } } fflush(stderr); v = (char *) &Field(v, size + 1); } if(v > (char *) Val_hp(caml_young_end)) { fprintf(stderr, "%s: heap is bogus\n", name); fflush(stderr); return; } /* * Phase 2: check that all the fields point to actual * values. */ v = (char *) Val_hp(caml_young_ptr); while(v < caml_young_end) { size = Wosize_val(v); if(Tag_val(v) < No_scan_tag) { fprintf(stderr, "%s: scanning 0x%08lx: size %lud, tag = %d\n", name, (unsigned long) v, size, Tag_val(v)); fflush(stderr); for(i = 0; i != size; i++) { char *p = (char *) Field(v, i); if(Is_block((value) p)) { if(p >= caml_young_limit && p < caml_young_ptr) { fprintf(stderr, "%s: pointer refers to empty young space\n", name); fflush(stderr); return; } if(p >= caml_young_ptr && p < caml_young_end) search_pointer(pointers, name, index, p, v, i); } } } v = (char *) &Field(v, size + 1); } } static void lm_heap_check_aux2(char *name) { /* char *start, *ptr, *end; */ char *v; header_t hd; mlsize_t size; unsigned i; /* start = caml_young_start; */ /* ptr = caml_young_ptr; */ /* end = caml_young_end; */ fprintf(stderr, "AAA: %s: [0x%08lx, 0x%08lx, 0x%08lx, 0x%08lx] (%ld/%ld/%ld bytes)\n", name, (unsigned long) caml_young_start, (unsigned long) caml_young_ptr, (unsigned long) caml_young_limit, (unsigned long) caml_young_end, ((unsigned long) caml_young_end) - (unsigned long) caml_young_ptr, ((unsigned long) caml_young_end) - (unsigned long) caml_young_limit, ((unsigned long) caml_young_end) - (unsigned long) caml_young_start); fflush(stderr); /* * Phase 1: check that the headers have the right sizes. */ v = (char *) Val_hp(caml_young_ptr); while(v < caml_young_end) { hd = Hd_val(v); if(hd == Debug_free_minor) { fprintf(stderr, "Bogus pointer: 0x%08lx\n", (unsigned long) v); fflush(stderr); v += sizeof(header_t); } else { size = Wosize_val(v); for(i = 0; i != size; i++) { char *p = (char *) Field(v, i); if(p >= caml_young_end && p < caml_young_ptr) { fprintf(stderr, "%s: Found a bogus pointer: 0x%08lx[%d] = 0x%08lx\n", name, (unsigned long) v, i, (unsigned long) p); fflush(stderr); abort(); } } v = (char *) &Field(v, size + 1); } } } value lm_heap_check(value v_name) { lm_heap_check_aux1(String_val(v_name)); lm_heap_check_aux2(String_val(v_name)); return Val_unit; } omake-0.10.3/src/clib/readline.c0000644000175000017500000011565413177364666015001 0ustar gerdgerd/* * Read input from the terminal. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004-2007 Mojave Group, Caltech and HRL Laboratories, LLC * * 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; version 2 * of the License. * * 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, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * * Additional permission is given to link this library with the * with the Objective Caml runtime, and to redistribute the * linked executables. See the file LICENSE.OMake for more details. * * Author: Jason Hickey @email{jyh@cs.caltech.edu} * Modified by: Aleksey Nogin @email{nogin@metaprl.org}, @email{anogin@hrl.com} * @end[license] */ #include #include #include #include #include #include #include /* * XXX: HACK (nogin 02/28/07): * CAMLreturn with non-value types is wrong in 3.09.3 and later; CAMLreturnT was added in 3.09.4 and * 3.10 to address this, but in 3.09.3 we are out of luck! */ #ifndef CAMLreturnT #define CAMLreturnT(type, result) do{ \ type caml__temp_result = (result); \ caml_local_roots = caml__frame; \ return (caml__temp_result); \ }while(0) #endif #ifdef WIN32 # include # include /* Disable some of the warnings */ # pragma warning( disable : 4100 4127 4505 4702 4996 4189) #else # include # include # include # include # ifdef READLINE_ENABLED # include # include # endif #endif /* !WIN32 */ /* * Maximum number of characters in an input line. Defined by limits.h on Unix. */ #ifndef LINE_MAX #define LINE_MAX 2048 #endif /* * Prompts shouldn't be too wild. * In particular, they should be less than an average line length. */ #define MAX_PROMPT_LENGTH 70 /* * Maximum length of the history filename. Defined by limits.h on Unix. */ #ifndef PATH_MAX #define PATH_MAX 2048 #endif /* * Space for completions array. */ #define COMPLETION_LENGTH 10 /* * Name of the command completion callback. */ #ifdef READLINE_ENABLED static char omake_filename_completion[] = "omake_filename_completion"; static char omake_command_completion[] = "omake_command_completion"; #endif /************************************************************************ * Completions. */ /* * Linked list of filename completions. */ typedef struct _completion_info { /* Current directory (needed for filename completion) */ char dir[PATH_MAX]; /* List of completions */ char **completions; } CompletionInfo; /* * Command completions use a callback. */ #ifdef READLINE_ENABLED static char **readline_completion(char *omake_completion, const char *text) { CAMLparam0(); CAMLlocal2(request, response); char *namep, **completions; value *callbackp; int i, length; #ifdef WIN32 /* This is bogus but temporary */ (void) caml__dummy_request; #endif /* Find the callback, abort if it doesn't exist */ callbackp = caml_named_value(omake_completion); if(callbackp == 0 || *callbackp == 0) CAMLreturnT(char **, 0); /* The callback returns an array of strings */ request = caml_copy_string(text); response = caml_callback(*callbackp, request); /* Copy the array of strings */ length = Wosize_val(response); if(length == 0) CAMLreturnT(char **, 0); completions = malloc((length + 1) * sizeof(char *)); if(completions == 0) CAMLreturnT(char **, 0); for(i = 0; i != length; i++) { namep = strdup(String_val(Field(response, i))); if(namep == 0) break; completions[i] = namep; } completions[i] = 0; CAMLreturnT(char **, completions); } #endif /************************************************************************ * Readline simulation for Win32. */ #ifdef WIN32 /* * Number of fields in the history. */ #define MAX_HISTORY_LENGTH 256 /* * Console modes. */ #define RAW_CONSOLE_MODE (ENABLE_WINDOW_INPUT) #define COOKED_CONSOLE_MODE (ENABLE_ECHO_INPUT \ | ENABLE_LINE_INPUT\ | ENABLE_MOUSE_INPUT\ | ENABLE_PROCESSED_INPUT\ | ENABLE_WINDOW_INPUT) /* * Number of events to read from the console. */ #define INPUT_COUNT 10 /* * A ReadLine-style buffer. * The buffer should be long enough to hold the input, * and the line terminator, and the string terminator. */ typedef struct _line_buffer { char buffer[LINE_MAX + 3]; int length, index; } LineBuffer; typedef struct _readline { /* History */ LineBuffer history[MAX_HISTORY_LENGTH]; LineBuffer current; // The line being edited LineBuffer display; // What is displayed int start; // First line in the history int length; // Number of lines in the history int index; // Current line in the history int offset; // Base history offset char filename[PATH_MAX]; // Where is the history saved? /* Input processing */ int escape; // Should next char be escaped? /* Prompts */ char prompt[MAX_PROMPT_LENGTH]; int prompt_length; /* Console information */ int is_console; // Are we connected to a console? int force_prompt; // Force the prompt even if not a console HANDLE console_in; // Input console HANDLE console_out; // Screen buffer int x, y; // Original cursor position int w, h; // Total size of the window // Completion info CompletionInfo completion; } ReadLine; /* * The codes for each operation. */ typedef enum { CODE_SUCCESS, CODE_EOL, CODE_EOF } ProcessCode; /************************************************************************ * Utilities. */ /* * Print an error message. */ static void print_error_code(const char *name, DWORD code) { LPTSTR buffer; FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, // Format flags NULL, // Location of the message code, // Error code MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), // Language (LPTSTR) &buffer, // Message buffer 0, // Buffer size NULL); // Arguments /* Print the message */ fprintf(stderr, "%s: failed with code %d: %s\n", name, errno, buffer); fflush(stderr); LocalFree(buffer); } static void print_error(const char *name) { print_error_code(name, GetLastError()); } /************************************************************************ * Operations on LineBuffers */ /* * Index positions. */ static int IndexOfNextWord(LineBuffer *linep) { int index; index = linep->index; while(index < linep->length && linep->buffer[index] > ' ') index++; while(index < linep->length && linep->buffer[index] <= ' ') index++; return index; } static int IndexOfPrevWord(LineBuffer *linep) { int index; index = linep->index; while(index && linep->buffer[index] <= ' ') index--; while(index && linep->buffer[index] > ' ') index--; return index; } /* * Move the cursor. */ static void LineMoveNextChar(LineBuffer *linep) { if(linep->index != linep->length) linep->index++; } static void LineMovePrevChar(LineBuffer *linep) { if(linep->index) linep->index--; } static void LineMoveFirstChar(LineBuffer *linep) { linep->index = 0; } static void LineMoveLastChar(LineBuffer *linep) { linep->index = linep->length; } static void LineMoveNextWord(LineBuffer *linep) { linep->index = IndexOfNextWord(linep); } static void LineMovePrevWord(LineBuffer *linep) { linep->index = IndexOfPrevWord(linep); } /* * Insert a char at the current position. */ static void LineInsertChar(LineBuffer *linep, char c) { int amount; if(linep->index == LINE_MAX) return; /* Insert it */ amount = linep->length - linep->index; memmove(linep->buffer + linep->index + 1, linep->buffer + linep->index, amount); linep->buffer[linep->index] = c; linep->index++; linep->length++; } /* * Delete characters between the current and the new index. */ static void LineDeleteRange(LineBuffer *linep, int index) { int amount, remaining, tmp; if(index < linep->index) { tmp = index; index = linep->index; linep->index = tmp; } amount = index - linep->index; remaining = linep->length - index; memmove(linep->buffer + linep->index, linep->buffer + index, amount); linep->length -= amount; } static void LineDeletePrevChar(LineBuffer *linep) { if(linep->index) LineDeleteRange(linep, linep->index - 1); } static void LineDeleteNextChar(LineBuffer *linep) { if(linep->index < linep->length) LineDeleteRange(linep, linep->index + 1); else if(linep->index) LineDeleteRange(linep, linep->index - 1); } static void LineDeletePrevWord(LineBuffer *linep) { LineDeleteRange(linep, IndexOfPrevWord(linep)); } static void LineDeleteNextWord(LineBuffer *linep) { LineDeleteRange(linep, IndexOfNextWord(linep)); } static void LineDeleteToBOL(LineBuffer *linep) { LineDeleteRange(linep, 0); } static void LineDeleteToEOL(LineBuffer *linep) { linep->length = linep->index; } static void LineDeleteLine(LineBuffer *linep) { linep->index = 0; linep->length = 0; } /* * Insert an EOL. */ static void LineInsertEOL(LineBuffer *linep) { linep->buffer[linep->length] = '\r'; linep->buffer[linep->length + 1] = '\n'; linep->length += 2; linep->index = linep->length; } /************************************************************************ * ReadLine operations. */ /* * Allocate a ReadLine struct. */ static ReadLine *AllocReadLine(int is_console, HANDLE console_in, HANDLE console_out) { ReadLine *readp; /* Allocate and zero */ readp = (ReadLine *) malloc(sizeof(ReadLine)); if(readp) { memset(readp, 0, sizeof(ReadLine)); readp->is_console = is_console; readp->console_in = console_in; readp->console_out = console_out; readp->offset = 1; } return readp; } /* * Copy the current line from the history. */ static void LoadFromHistory(ReadLine *readp) { LineBuffer *linep; linep = readp->history + ((readp->start + readp->index) % MAX_HISTORY_LENGTH); readp->current = *linep; } /* * Set the console stats. */ static int ConsoleRaw(ReadLine *readp) { CONSOLE_SCREEN_BUFFER_INFO info; int status; /* Set in raw mode */ status = SetConsoleMode(readp->console_in, RAW_CONSOLE_MODE); if(status == 0) { print_error("SetConsoleMode"); return -1; } status = SetConsoleMode(readp->console_out, ENABLE_PROCESSED_OUTPUT | ENABLE_WRAP_AT_EOL_OUTPUT); if(status == 0) { print_error("SetConsoleMode"); return -1; } /* Remember where the cursor currently is */ status = GetConsoleScreenBufferInfo(readp->console_out, &info); if(status == 0) { print_error("GetConsoleScreenBufferInfo"); readp->x = 0; readp->y = 0; readp->w = 80; readp->h = 24; } else { readp->x = info.dwCursorPosition.X; readp->y = info.dwCursorPosition.Y; readp->w = info.dwSize.X; readp->h = info.dwSize.Y; if(readp->w <= 0) readp->w = 1; if(readp->h <= 0) readp->h = 1; } return 0; } /* * Set the console stats. */ static int ConsoleCooked(ReadLine *readp) { int status; status = SetConsoleMode(readp->console_in, COOKED_CONSOLE_MODE); if(status == 0) { print_error("SetConsoleMode"); return -1; } return 0; } /* * Move the cursor to the right index. */ static void UpdateCursor(ReadLine *readp, int index) { int i, x, y; char *bufp; COORD pos; bufp = readp->current.buffer; x = readp->x; y = readp->y; for(i = 0; i != index; i++) { switch(bufp[i]) { case 0: break; case '\r': x = 0; break; case '\n': y++; break; case '\t': x = (x + 8) & ~7; break; default: x++; break; } if(x == readp->w) { x = 0; y++; } if(y == readp->h) { readp->y--; y = readp->h - 1; } } /* Set the cursor */ pos.X = (SHORT) x; pos.Y = (SHORT) y; SetConsoleCursorPosition(readp->console_out, pos); } /* * Go to the next line in the history. */ static void ReadNextLine(ReadLine *readp) { if(readp->index < readp->length) readp->index++; LoadFromHistory(readp); } static void ReadPrevLine(ReadLine *readp) { if(readp->index > 0) readp->index--; LoadFromHistory(readp); } /* * Clear the screen. */ static void ReadClearScreen(ReadLine *readp) { COORD pos; DWORD count; /* Flood the screen with whitespace */ pos.X = 0; pos.Y = 0; count = readp->w * readp->h; FillConsoleOutputCharacter(readp->console_out, (TCHAR) ' ', count, pos, &count); /* Move the cursor and print the prompt */ readp->x = 0; readp->y = 0; UpdateCursor(readp, 0); WriteFile(readp->console_out, readp->prompt, readp->prompt_length, &count, NULL); /* Move the standard cursor */ readp->y = readp->prompt_length / readp->w; readp->x = readp->prompt_length % readp->w; UpdateCursor(readp, 0); } /* * Refresh the current line in the console. */ static void Refresh(ReadLine *readp) { LineBuffer *old, *current; DWORD count; int end; old = &readp->display; current = &readp->current; /* Write to max of old and new lengths */ if(current->length < old->length) end = old->length; else end = current->length; /* Copy the entire line, and pad with spaces */ memcpy(old->buffer, current->buffer, current->length); memset(old->buffer + current->length, ' ', end - current->length); /* Write the data to the console */ UpdateCursor(readp, 0); WriteFile(readp->console_out, // Echo to the console old->buffer, // Data to write end, // Write all characters &count, // Number of bytes written NULL); // Not overlapped UpdateCursor(readp, current->index); old->index = current->index; old->length = current->length; } /************************************************************************ * Processor. */ /* * Send the character to the current process. */ static ProcessCode process_char(ReadLine *readp, char c) { LineBuffer *linep; ProcessCode code; code = CODE_SUCCESS; linep = &readp->current; if(readp->escape) { readp->escape = 0; LineInsertChar(linep, c); } else { switch(c) { case 0: break; case 'A'-'@': LineMoveFirstChar(linep); break; case 'B'-'@': LineMovePrevChar(linep); break; case 'D'-'@': code = CODE_EOF; break; case 'E'-'@': LineMoveLastChar(linep); break; case 'F'-'@': LineMoveNextChar(linep); break; case 'H'-'@': LineDeletePrevChar(linep); break; case 'K'-'@': LineDeleteToEOL(linep); break; case 'L'-'@': ReadClearScreen(readp); break; case 'P'-'@': ReadPrevLine(readp); break; case 'N'-'@': ReadNextLine(readp); break; case 'V'-'@': readp->escape = 1; break; case 'W'-'@': LineDeletePrevWord(linep); break; case 'X'-'@': case 'C'-'@': LineDeleteLine(linep); break; case 127: LineDeleteNextChar(linep); break; case '\n': case '\r': LineInsertEOL(linep); code = CODE_EOL; break; case '\\'-'@': case 'Z'-'@': break; default: LineInsertChar(linep, c); break; } } Refresh(readp); return code; } /* * Input loop. */ static ProcessCode processor(ReadLine *readp) { INPUT_RECORD input[INPUT_COUNT]; INPUT_RECORD *event; KEY_EVENT_RECORD *key; ProcessCode code; int status; DWORD count, i; char c; /* Input loop */ while(1) { caml_enter_blocking_section(); status = ReadConsoleInput(readp->console_in, input, INPUT_COUNT, &count); caml_leave_blocking_section(); if(status == 0) { print_error("ReadConsoleInput"); return CODE_EOF; } /* Perform each event */ for(i = 0; i != count; i++) { event = &input[i]; switch(event->EventType) { case KEY_EVENT: /* Send the key to the process */ key = &event->Event.KeyEvent; c = key->uChar.AsciiChar; if(key->bKeyDown) { code = process_char(readp, c); if(code != CODE_SUCCESS) return code; } break; case MOUSE_EVENT: case WINDOW_BUFFER_SIZE_EVENT: case MENU_EVENT: case FOCUS_EVENT: default: break; } } } } /* * Read in cooked mode. */ static void readline_cooked(ReadLine *readp) { char *s; caml_enter_blocking_section(); s = fgets(readp->current.buffer, LINE_MAX, stdin); caml_leave_blocking_section(); if(s == 0) caml_raise_end_of_file(); readp->current.length = strlen(readp->current.buffer); } /* * Read in raw console mode. */ static void readline_raw(ReadLine *readp) { /* Process in raw mode */ ConsoleRaw(readp); processor(readp); ConsoleCooked(readp); } /* * Once reading is done, reset all the buffers. */ static void readline_done(ReadLine *readp) { LineBuffer *linep; char *strp; int i, c; /* Copy the current line to the history */ linep = readp->history + ((readp->start + readp->length) % MAX_HISTORY_LENGTH); *linep = readp->current; /* Do not include the eol in the history */ strp = linep->buffer; i = linep->length; while(i > 0) { c = strp[i - 1]; if(c == '\n' || c == '\r') i--; else break; } strp[i] = 0; linep->length = i; linep->index = i; /* Scroll the history if the line is nonempty */ if(i) { if(readp->length < MAX_HISTORY_LENGTH - 1) readp->length++; else { readp->start = (readp->start + 1) % MAX_HISTORY_LENGTH; readp->offset++; } readp->index = readp->length; } /* Clear the next line in the history */ linep = readp->history + ((readp->start + readp->length) % MAX_HISTORY_LENGTH); linep->index = 0; linep->length = 0; /* Clear the display buffer */ linep = &readp->display; linep->index = 0; linep->length = 0; /* Data is copied from the current buffer */ linep = &readp->current; linep->index = 0; } /* * Read a line from the console. */ static void readline(ReadLine *readp, const char *promptp) { int len; /* Get the prompt */ len = strlen(promptp); if(len > sizeof(readp->prompt) - 1) len = sizeof(readp->prompt) - 1; memcpy(readp->prompt, promptp, len); readp->prompt[len] = 0; readp->prompt_length = len; /* Display the prompt */ if(readp->is_console || readp->force_prompt) { printf("%s", readp->prompt); fflush(stdout); } /* Read the input line */ if(readp->is_console) readline_raw(readp); else readline_cooked(readp); /* Add this line to the history */ readline_done(readp); } /* * Load the history from a file. */ static int do_readline_load_history(ReadLine *readp, const char *filenamep) { char line[LINE_MAX + 32]; LineBuffer *linep; FILE *filep; char *strp; if(strlen(filenamep) >= PATH_MAX) return -1; strcpy(readp->filename, filenamep); if((filep = fopen(filenamep, "r")) == NULL) return -1; while(fgets(line, sizeof(line) - 1, filep)) { /* Skip over the line number */ strp = line; while(isspace(*strp)) strp++; while(isdigit(*strp)) strp++; while(isspace(*strp)) strp++; /* Copy into a line buffer */ linep = readp->history + ((readp->start + readp->length) % MAX_HISTORY_LENGTH); linep->length = strlen(strp); if(linep->length == 0) continue; if(linep->length > LINE_MAX) linep->length = LINE_MAX; else linep->length--; memcpy(linep->buffer, strp, linep->length); linep->index = linep->length; /* Now scroll the history */ if(readp->length < MAX_HISTORY_LENGTH - 1) readp->length++; else { readp->start = (readp->start + 1) % MAX_HISTORY_LENGTH; readp->offset++; } readp->index = readp->length; } fclose(filep); return 0; } /* * Save the history to a file. */ static int do_readline_save_history(ReadLine *readp) { int i, offset, start, length; LineBuffer *linep; FILE *filep; if(*readp->filename == 0) return -1; if((filep = fopen(readp->filename, "w")) == NULL) return -1; offset = readp->offset; start = readp->start; length = readp->length; for(i = 0; i < length; i++) { linep = readp->history + ((start + i) % MAX_HISTORY_LENGTH); linep->buffer[linep->length] = 0; fprintf(filep, "%5d %s\n", offset + i, linep->buffer); } fclose(filep); return 0; } /************************************************************************ * Main routines. */ /* * Only one readline buffer. */ static ReadLine *readp; /* * Is input a tty? */ value omake_isatty(value v_unit) { return Val_int(readp->is_console); } value omake_is_interactive(value v_unit) { return Val_int(readp->is_console || readp->force_prompt); } value omake_readline_flush(value v_unit) { return Val_unit; } /* * Some of these history functions can be implemented. */ value omake_where_history(value v_unit) { return Val_int(readp->offset + readp->length); } value omake_readline_load_file(value v_file) { do_readline_load_history(readp, String_val(v_file)); return Val_unit; } value omake_readline_save_file(value v_unit) { do_readline_save_history(readp); return Val_unit; } value omake_readline_set_length(value v_length) { return Val_unit; } value omake_readline_set_directory(value v_dir) { return Val_unit; } value omake_readline_history(value v_unit) { int i, length, start, offset; char store[MAX_HISTORY_LENGTH][100]; char *data[MAX_HISTORY_LENGTH + 1]; char *strp; LineBuffer *linep; start = readp->start; length = readp->length; offset = readp->offset; for(i = 0; i < length; i++) { linep = readp->history + ((start + i) % MAX_HISTORY_LENGTH); strp = store[i]; sprintf(strp, "%-5d %.70s", i + offset, linep->buffer); data[i] = strp; } data[i] = 0; return caml_copy_string_array((char const **) data); } /* * Force the prompt anyway. */ value omake_interactive(value v_bool) { int interactive = Int_val(v_bool); if(interactive) readp->force_prompt = 1; else { readp->is_console = 0; readp->force_prompt = 0; } return Val_unit; } /* * Read an entire line from the input. */ value omake_readline(value v_prompt) { LineBuffer *linep; value v_str; /* Get the line */ readline(readp, String_val(v_prompt)); /* Copy it to a string */ linep = &readp->current; v_str = caml_alloc_string(linep->length); memcpy(String_val(v_str), linep->buffer, linep->length); /* Reset the current buffer */ linep->index = 0; linep->length = 0; return v_str; } /* * Read a single character from the input. */ value omake_readstring(value v_prompt, value v_buf, value v_off, value v_len) { LineBuffer *linep; int off, len, amount; char *buf, *prompt; /* If the buffer is empty, read the next line */ prompt = String_val(v_prompt); linep = &readp->current; if(linep->index == linep->length) { linep->index = 0; linep->length = 0; readline(readp, prompt); } /* Get as much as possible */ buf = String_val(v_buf); off = Int_val(v_off); len = Int_val(v_len); amount = linep->length - linep->index; if(amount > len) amount = len; memcpy(buf + off, linep->buffer + linep->index, amount); linep->index += amount; return Val_int(amount); } /* * Attach to the console. */ value omake_readline_init(value v_unit) { HANDLE c_stdin, c_stdout, handle; DWORD status, mode; int is_console; /* Get the stdin handle */ c_stdin = GetStdHandle(STD_INPUT_HANDLE); c_stdout = GetStdHandle(STD_OUTPUT_HANDLE); if(c_stdin == INVALID_HANDLE_VALUE || c_stdout == INVALID_HANDLE_VALUE) caml_failwith("omake_readline_init: no standard channels"); /* Check if it is a console */ is_console = 1; status = GetConsoleMode(c_stdin, &mode); if(status) { /* Make sure output is to the console */ handle = CreateFile("CONOUT$", GENERIC_READ | GENERIC_WRITE, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if(handle == INVALID_HANDLE_VALUE) is_console = 0; else c_stdout = handle; } else is_console = 0; /* Good, we have a console */ readp = AllocReadLine(is_console, c_stdin, c_stdout); return Val_unit; } #else /* !WIN32 */ /************************************************************************ * Unix readline interface. */ #ifdef RL_PROMPT_START_IGNORE #define INVIS_START RL_PROMPT_START_IGNORE #define INVIS_END RL_PROMPT_END_IGNORE #else #define INVIS_START '\001' #define INVIS_END '\002' #endif /* * Input state. */ typedef struct _readline { /* Console info */ int console_in; int is_console; /* Prompts */ char * prompt; int prompt_size; int force_prompt; /* Buffered data */ char * buffer; int buffer_size; int index; int length; /* Current directory */ char dir[PATH_MAX]; } ReadLine; /* * Allocate the struct. */ static ReadLine *AllocReadLine(int is_console, int console_in) { ReadLine *readp; /* Allocate */ readp = (ReadLine *) malloc(sizeof(ReadLine)); if(readp == NULL) caml_failwith("AllocReadLine: out of memory"); memset(readp, 0, sizeof(ReadLine)); /* Initialize */ readp->buffer = malloc(LINE_MAX); if (readp->buffer == NULL) caml_failwith("AllocReadLine: out of memory"); readp->buffer_size = LINE_MAX; readp->prompt = malloc(MAX_PROMPT_LENGTH); if (readp->prompt == NULL) caml_failwith("AllocReadLine: out of memory"); readp->prompt_size = MAX_PROMPT_LENGTH; readp->console_in = console_in; readp->is_console = is_console; readp->dir[0] = '/'; return readp; } /* * Read in cooked mode. */ static void readline_cooked(ReadLine *readp) { if(readp->is_console || readp->force_prompt) { printf("%s", readp->prompt); fflush(stdout); } if(fgets(readp->buffer, readp->buffer_size, stdin) == NULL) readp->length = 0; else readp->length = strlen(readp->buffer); } /* * Read in raw console mode. */ #ifdef READLINE_ENABLED static void readline_raw(ReadLine *readp) { char *linep, *expansion = NULL; int length, result; prompt: #ifdef READLINE_GNU rl_on_new_line(); #endif linep = readline(readp->prompt); if(linep && *linep && (readp->is_console || readp->force_prompt)) { /* Perform a history expansion */ result = history_expand(linep, &expansion); free(linep); switch(result) { case 0: /* No expansion */ break; case 1: /* There was an expansion */ printf("%s\n", expansion); fflush(stdout); break; case 2: /* Display, but do not execute */ printf("%s\n", expansion); fflush(stdout); free(expansion); goto prompt; default: /* There was an error during expansion */ printf("History expansion failed\n"); fflush(stdout); free(expansion); goto prompt; } /* Successful expansion */ add_history(expansion); length = strlen(expansion); if(length >= readp->buffer_size) { char *new_buffer = malloc(length + 1); if(new_buffer == NULL) caml_failwith("readline_raw: out of memory"); free(readp->buffer); readp->buffer = new_buffer; readp->buffer_size = length + 1; } memcpy(readp->buffer, expansion, length); readp->buffer[length] = '\n'; readp->length = length + 1; free(expansion); } else if(linep) { free(linep); readp->buffer[0] = '\n'; readp->length = 1; } else readp->length = 0; } #else /* !READLINE_ENABLED */ #define readline_raw readline_cooked #endif /* !READLINE_ENABLED */ /* * Read a line from the console. */ static void do_readline(ReadLine *readp, const char *promptp) { int i; /* Get the prompt */ int is_vis = 1, vis_length = 0; int last_vis[3] = {0,0,0}, vis_ind = 0; #ifdef RL_PROMPT_START_IGNORE int copy_markers = readp -> is_console; #else #define copy_markers 0 #endif for(i = 0; *promptp; promptp++) { if (i == readp->prompt_size - 1) { /* Ran out of memory, allocate bigger buffer */ char * old_prompt = readp->prompt; int new_size = readp->prompt_size * 2; readp->prompt = malloc(new_size); if (readp->prompt == NULL) { readp->prompt = old_prompt; caml_failwith("do_readline: out of memory"); } else { memcpy(readp->prompt, old_prompt, i); free(old_prompt); readp->prompt_size = new_size; } } if (*promptp == INVIS_START) is_vis = 0; if (is_vis) { vis_length++; if (vis_length == MAX_PROMPT_LENGTH + 1) { /* We just ran out */ readp->prompt[last_vis[0]] = '.'; readp->prompt[last_vis[1]] = '.'; readp->prompt[last_vis[2]] = '.'; } } if (((!is_vis) || (vis_length <= MAX_PROMPT_LENGTH)) && (copy_markers || ((*promptp != INVIS_START) && (*promptp != INVIS_END)))) { if (is_vis) last_vis[vis_ind++ % 3] = i; readp->prompt[i++] = *promptp; } if (*promptp == INVIS_END) is_vis = 1; } readp->prompt[i] = 0; /* Read the input line */ if(readp->is_console) readline_raw(readp); else readline_cooked(readp); readp->index = 0; } /* * History file and length. */ #ifdef READLINE_ENABLED static char readline_file[2048]; static int readline_length; #endif static void do_readline_load_file(const char *filep) { #ifdef READLINE_ENABLED /* Check the length */ if(strlen(filep) >= sizeof(readline_file)) caml_invalid_argument("omake_readline_file: filename is too long"); /* If the file has changed, load the file */ if(strcmp(readline_file, filep)) { strcpy(readline_file, filep); read_history(readline_file); } #endif /* READLINE_ENABLED */ } static void do_readline_save_file() { #ifdef READLINE_ENABLED if(*readline_file) write_history(readline_file); #endif /* READLINE_ENABLED */ } static void do_readline_set_length(int length) { #ifdef READLINE_ENABLED /* If the length has changed, stifle the history */ if(length != readline_length) { readline_length = length; stifle_history(readline_length); } #endif /* READLINE_ENABLED */ } /************************************************************************ * Completion functions. */ static ReadLine *readp; #ifdef READLINE_ENABLED /* * Flatten the list. */ static char **readline_completion_matches(const char *text, int first, int last) { char **matches; int amount; /* Sanity checking */ amount = last - first; if(amount <= 0 || amount >= LINE_MAX) return NULL; /* Three kinds of completion */ if(first == 0) matches = readline_completion(omake_command_completion, text); else matches = readline_completion(omake_filename_completion, text); return matches; } #endif /* READLINE_ENABLED */ /************************************************************************ * Public functions. */ /* * Is input a tty? */ value omake_isatty(value v_unit) { return Val_int(readp->is_console); } value omake_is_interactive(value v_unit) { return Val_int(readp->is_console || readp->force_prompt); } value omake_readline_flush(value v_unit) { if(readp->is_console) fflush(stdin); return Val_unit; } value omake_where_history(value v_unit) { int i; #ifdef READLINE_ENABLED i = history_base + history_length; #else i = 1; #endif return Val_int(i); } value omake_readline_load_file(value v_file) { do_readline_load_file(String_val(v_file)); return Val_unit; } value omake_readline_save_file(value v_unit) { do_readline_save_file(); return Val_unit; } value omake_readline_set_length(value v_length) { do_readline_set_length(Int_val(v_length)); return Val_unit; } value omake_readline_set_directory(value v_dir) { /* Copy the current directory */ strncpy(readp->dir, String_val(v_dir), PATH_MAX - 1); readp->dir[PATH_MAX - 1] = 0; return Val_unit; } value omake_readline_history(value v_unit) { #ifdef READLINE_ENABLED char *data[history_length + 1]; char entries[history_length][80]; int i; #ifdef READLINE_GNU HIST_ENTRY **the_list; the_list = history_list(); i = 0; if(the_list) { while(the_list[i]) { data[i] = entries[i]; sprintf(data[i], "%-5d %.70s", i + history_base, the_list[i]->line); data[i][79] = 0; i++; } } data[i] = 0; #else /* !READLINE_GNU */ /* * BSD readline doesn't have history_list, or any way to get the complete * history in one call. */ for(i = 0; i < history_length; i++) { HIST_ENTRY *entryp; entryp = history_get(history_base + i); if(entryp == 0) break; data[i] = entries[i]; sprintf(data[i], "%-5d %.70s", i + history_base, entryp->line); data[i][79] = 0; } data[i] = 0; #endif /* !READLINE_GNU */ #else /* !READLINE_ENABLED */ char *data[1]; data[0] = 0; #endif /* !READLINE_ENABLED */ return caml_copy_string_array((char const **) data); } /* * Force the prompt anyway. */ value omake_interactive(value v_bool) { int interactive = Int_val(v_bool); if(interactive) readp->force_prompt = 1; else { readp->is_console = 0; readp->force_prompt = 0; } return Val_unit; } /* * Read an entire line from the input. */ value omake_readline(value v_prompt) { value v_str; /* Get the line */ do_readline(readp, String_val(v_prompt)); /* Copy it to the buffer */ v_str = caml_alloc_string(readp->length); memcpy(String_val(v_str), readp->buffer, readp->length); /* Reset the current buffer */ readp->index = 0; readp->length = 0; return v_str; } /* * Read a single character from the input. */ value omake_readstring(value v_prompt, value v_buf, value v_off, value v_len) { int off, len, amount; char *buf, *prompt; /* If the buffer is empty, read the next line */ prompt = String_val(v_prompt); if(readp->index == readp->length) { readp->index = 0; readp->length = 0; do_readline(readp, prompt); } /* Get as much as possible */ buf = String_val(v_buf); off = Int_val(v_off); len = Int_val(v_len); amount = readp->length - readp->index; if(amount > len) amount = len; memcpy(buf + off, readp->buffer + readp->index, amount); readp->index += amount; return Val_int(amount); } /* * Attach to the console. */ value omake_readline_init(value v_unit) { readp = AllocReadLine(isatty(0), 0); #ifdef READLINE_ENABLED using_history(); rl_attempted_completion_function = readline_completion_matches; rl_completion_append_character = 0; #endif return Val_unit; } #endif /* !WIN32 */ value omake_rl_prompt_wrappers(value v_unit) { CAMLparam1(v_unit); CAMLlocal1(buf); #ifdef INVIS_START { char begin[2] = { INVIS_START, 0}; char end [2] = { INVIS_END, 0}; CAMLlocal2(s1, s2); s1 = caml_copy_string(begin); s2 = caml_copy_string(end); buf = caml_alloc_tuple(2); Field(buf, 0) = s1; Field(buf, 1) = s2; } #else /* INVIS_START */ { CAMLlocal1(emptystr); emptystr = caml_copy_string(""); buf = caml_alloc_tuple(2); Field(buf, 0) = emptystr; Field(buf, 1) = emptystr; } #endif /* INVIS_START */ CAMLreturn(buf); } /* * vim:tw=100:ts=4:et:sw=4:cin */ omake-0.10.3/src/clib/lm_ctype.c0000644000175000017500000000446513177364666015027 0ustar gerdgerd/* * Get characters from the current locale. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004-2006 Mojave group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey @email{jyh@cs.caltech.edu} * Modified by: Aleksey Nogin @email{nogin@cs.caltech.edu} * @end[license] */ #include #include #include #include #include #include #include #include #ifdef WIN32 #include /* Disable some of the warnings */ #pragma warning( disable : 4100 ) #endif /* WIN32 */ /* * Character classes. */ static value get_chars(int (*f)(int)) { char buf[256]; value s; char *p; int i; p = buf; for(i = 0; i != 256; i++) { if(f(i)) *p++ = (char) i; } s = alloc_string(p - buf); memcpy(String_val(s), buf, p - buf); return s; } value omake_alnum(value v_unit) { return get_chars(isalnum); } value omake_alpha(value v_unit) { return get_chars(isalpha); } value omake_graph(value v_unit) { return get_chars(isgraph); } value omake_lower(value v_unit) { return get_chars(islower); } value omake_upper(value v_unit) { return get_chars(isupper); } value omake_punct(value v_unit) { return get_chars(ispunct); } value omake_space(value v_unit) { return get_chars(isspace); } omake-0.10.3/src/clib/lm_printf.c0000644000175000017500000000714413177364666015202 0ustar gerdgerd/* * These printers use printf, both to ensure compatibility * with libc, and to make our life easier. */ #include #include #include #include #include #include #include #include #ifdef WIN32 #include /* Disable some of the warnings */ #pragma warning( disable : 4996) #endif /* WIN32 */ /* * Some large buffer. */ #define BUFSIZE (1 << 12) /* * Print a char. */ value ml_print_char(value v_fmt, value v_char) { char buffer[BUFSIZE]; char *fmt = String_val(v_fmt); char c = (char) Int_val(v_char); #ifdef HAVE_SNPRINTF if(snprintf(buffer, sizeof(buffer), fmt, c) < 0) failwith("ml_print_char"); #else if(sprintf(buffer, fmt, c) < 0) failwith("ml_print_char"); #endif return copy_string(buffer); } /* * Print an int. */ value ml_print_int(value v_fmt, value v_int) { char buffer[BUFSIZE]; char *fmt = String_val(v_fmt); int i = Int_val(v_int); #ifdef HAVE_SNPRINTF if(snprintf(buffer, sizeof(buffer), fmt, i) < 0) failwith("ml_print_int"); #else if(sprintf(buffer, fmt, i) < 0) failwith("ml_print_int"); #endif return copy_string(buffer); } /* * Print an int. */ value ml_print_float(value v_fmt, value v_float) { char buffer[BUFSIZE]; char *fmt = String_val(v_fmt); double x = Double_val(v_float); #ifdef HAVE_SNPRINTF if(snprintf(buffer, sizeof(buffer), fmt, x) < 0) failwith("ml_print_float"); #else if(sprintf(buffer, fmt, x) < 0) failwith("ml_print_float"); #endif return copy_string(buffer); } /* * Print a string. */ value ml_print_string(value v_fmt, value v_string) { char buffer[BUFSIZE], *bufp; int len, size, code; char *fmt, *s; value v_result; /* Degenerate case if the format is %s */ fmt = String_val(v_fmt); if(strcmp(fmt, "%s") == 0) return v_string; /* Make an attempt to ensure that the buffer is large enough */ s = String_val(v_string); len = strlen(s); if(len < BUFSIZE) { size = BUFSIZE; bufp = buffer; } else { size = len * 2; bufp = malloc(size); if(bufp == 0) failwith("ml_print_string"); } #ifdef HAVE_SNPRINTF code = snprintf(bufp, size, fmt, s); #else code = sprintf(bufp, fmt, s); #endif if(code < 0) { if(bufp != buffer) free(bufp); failwith("ml_print_string"); } v_result = copy_string(bufp); if(bufp != buffer) free(bufp); return v_result; } /* * Print a string. */ value ml_print_string2(value v_width, value v_fmt, value v_string) { char buffer[BUFSIZE], *bufp; int width, len, size, code; char *fmt, *s; value v_result; /* Degenerate case if the format is %s */ fmt = String_val(v_fmt); if(strcmp(fmt, "%s") == 0) return v_string; /* Make an attempt to ensure that the buffer is large enough */ s = String_val(v_string); len = strlen(s); width = Int_val(v_width); if(width > len) len = width; if(len < BUFSIZE / 2) { size = BUFSIZE; bufp = buffer; } else { size = len * 2; bufp = malloc(size); if(bufp == 0) failwith("ml_print_string"); } #ifdef HAVE_SNPRINTF code = snprintf(bufp, size, fmt, s); #else code = sprintf(bufp, fmt, s); #endif if(code < 0) { if(bufp != buffer) free(bufp); failwith("ml_print_string"); } v_result = copy_string(bufp); if(bufp != buffer) free(bufp); return v_result; } omake-0.10.3/src/clib/lm_notify.c0000644000175000017500000002132613177364666015206 0ustar gerdgerd/* * File-change notification. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] */ #include #include #include #include #include #include #include #ifdef FAM_ENABLED #ifdef WIN32 #include /* Disable some of the warnings */ #pragma warning( disable : 4100 4189 4127 4702 4996 ) #endif /* WIN32 */ #ifdef FAM_PSEUDO #include "fam_pseudo.h" #else /* FAM_PSEUDO */ #include #include #include #include #include #endif /* FAM_PSEUDO */ /* * Custom blocks. */ typedef struct { FAMConnection *fc; int is_open; } FAMInfo; #define FAMInfo_val(v) ((FAMInfo *) Data_custom_val(v)) #define FAMConnection_val(v) ((FAMInfo_val(v)->fc)) #ifdef HAVE_SNPRINTF #define ErrFmt(buffer, name) snprintf(buffer, sizeof(buffer), "%s: %s", name, FamErrlist[FAMErrno]) #else #define ErrFmt(buffer, name) sprintf(buffer, "%s: %s", name, FamErrlist[FAMErrno]) #endif #define CheckCode(fmt, expr) \ do { \ enter_blocking_section(); \ code = expr; \ leave_blocking_section(); \ if(code < 0) { \ char buffer[256]; \ ErrFmt(buffer, fmt); \ failwith(buffer); \ } \ } while(0) static int fam_connection_compare(value v1, value v2) { FAMConnection *info1 = FAMConnection_val(v1); FAMConnection *info2 = FAMConnection_val(v2); #ifdef FAM_PSEUDO return info1->id == info2->id ? 0 : info1->id < info2->id ? -1 : 1; #else /* FAM_PSEUDO */ return info1->fd == info2->fd ? 0 : info1->fd < info2->fd ? -1 : 1; #endif /* !FAM_PSEUDO */ } static long fam_connection_hash(value v) { return (long) FAMConnection_val(v); } static void fam_connection_finalize(value v_info) { FAMInfo *info; info = FAMInfo_val(v_info); if(info->is_open) { int code; CheckCode("om_notify_close", FAMClose(info->fc)); free(info->fc); info->is_open = 0; } } /* * Pass info in a custom block. */ static struct custom_operations fam_connection_ops = { "fam_connection", fam_connection_finalize, fam_connection_compare, fam_connection_hash, custom_serialize_default, custom_deserialize_default }; /* * Is this module enabled? */ value om_notify_enabled(value v_unit) { return Val_true; } /* * Open the FAM connection. */ value om_notify_open(value v_unit) { CAMLparam1(v_unit); CAMLlocal1(v); FAMConnection *fc; FAMInfo *info; int code; v = alloc_custom(&fam_connection_ops, sizeof(FAMInfo), 0, 1); info = FAMInfo_val(v); fc = malloc(sizeof(FAMConnection)); if(fc == 0) invalid_argument("om_notify_open: out of memory"); info->fc = fc; CheckCode("om_notify_open", FAMOpen(fc)); #ifdef HAVE_FAMNOEXISTS CheckCode("om_notify_open: FAMNoExists", FAMNoExists(fc)); #endif /* HAVE_FAMNOEXISTS */ info->is_open = 1; CAMLreturn(v); } /* * Close the FAM connection. */ value om_notify_close(value v_fc) { fam_connection_finalize(v_fc); return Val_unit; } /* * Get the file descriptor. */ value om_notify_fd(value v_fc) { #ifdef FAM_PSEUDO #ifdef FAM_INOTIFY FAMConnection *fc; fc = FAMConnection_val(v_fc); return Val_int(fc->id); #else /* FAM_PSEUDO && !FAM_INOTIFY */ failwith("No file descriptors in pseudo-FAM"); return Val_unit; #endif /* FAM_INOTIFY */ #else /* FAM_PSEUDO */ FAMConnection *fc; fc = FAMConnection_val(v_fc); return Val_int(FAMCONNECTION_GETFD(fc)); #endif /* FAM_PSEUDO */ } /* * Monitor a directory. */ value om_notify_monitor_directory(value v_fc, value v_name, value v_recursive) { CAMLparam3(v_fc, v_name, v_recursive); const char *name; FAMConnection *fc; FAMRequest request; int code, recursive; fc = FAMConnection_val(v_fc); name = String_val(v_name); recursive = Int_val(v_recursive); if(recursive) { #ifdef WIN32 CheckCode("om_notify_monitor_directory", FAMMonitorDirectoryTree(fc, name, &request, 0)); #else /* WIN32 */ failwith("om_notify_monitor_directory: recursive monitoring is not allowed"); #endif /* !WIN32 */ } else CheckCode("om_notify_monitor_directory", FAMMonitorDirectory(fc, name, &request, 0)); CAMLreturn(Val_int(request.reqnum)); } /* * Suspend the monitor. */ value om_notify_suspend(value v_fc, value v_request) { CAMLparam2(v_fc, v_request); FAMConnection *fc; FAMRequest request; int code; fc = FAMConnection_val(v_fc); request.reqnum = Int_val(v_request); CheckCode("om_notify_suspend", FAMSuspendMonitor(fc, &request)); CAMLreturn(Val_unit); } /* * Resume the monitor. */ value om_notify_resume(value v_fc, value v_request) { CAMLparam2(v_fc, v_request); FAMConnection *fc; FAMRequest request; int code; fc = FAMConnection_val(v_fc); request.reqnum = Int_val(v_request); CheckCode("om_notify_resume", FAMResumeMonitor(fc, &request)); CAMLreturn(Val_unit); } /* * Cancel the monitor. */ value om_notify_cancel(value v_fc, value v_request) { CAMLparam2(v_fc, v_request); FAMConnection *fc; FAMRequest request; int code; fc = FAMConnection_val(v_fc); request.reqnum = Int_val(v_request); CheckCode("om_notify_cancel", FAMCancelMonitor(fc, &request)); CAMLreturn(Val_unit); } /* * Check for a pending event. */ value om_notify_pending(value v_fc) { CAMLparam1(v_fc); FAMConnection *fc; int code; fc = FAMConnection_val(v_fc); CheckCode("om_notify_pending", FAMPending(fc)); CAMLreturn(code ? Val_true : Val_false); } /* * Get the next event. */ value om_notify_next_event(value v_fc) { CAMLparam1(v_fc); CAMLlocal2(v_name, v_tuple); FAMConnection *fc; FAMEvent event; int code; fc = FAMConnection_val(v_fc); CheckCode("om_notify_next_event", FAMNextEvent(fc, &event)); code = event.code; if(code < 1 || code > 10) failwith("om_notify_next_event: code out of bounds"); /* Allocate the string name */ v_name = copy_string(event.filename); /* Allocate the tuple */ v_tuple = alloc_tuple(3); Field(v_tuple, 0) = Val_int(event.fr.reqnum); Field(v_tuple, 1) = v_name; Field(v_tuple, 2) = Val_int(code - 1); CAMLreturn(v_tuple); } #else /* FAM_ENABLED */ /* * Is this module enabled? */ value om_notify_enabled(value v_unit) { return Val_false; } /* * Open the FAM connection. */ value om_notify_open(value v_unit) { return Val_unit; } /* * Get the file descriptor. */ value om_notify_fd(value v_fc) { invalid_argument("FAM not enabled"); return Val_unit; } /* * Close the FAM connection. */ value om_notify_close(value v_fc) { return Val_unit; } /* * Monitor a directory. */ value om_notify_monitor_directory(value v_fc, value v_name, value v_recursive) { return Val_int(0); } /* * Suspend the monitor. */ value om_notify_suspend(value v_fc, value v_request) { return Val_unit; } /* * Suspend the monitor. */ value om_notify_resume(value v_fc, value v_request) { return Val_unit; } /* * Suspend the monitor. */ value om_notify_cancel(value v_fc, value v_request) { return Val_unit; } /* * Check for a pending event. */ value om_notify_pending(value v_fc) { return Val_false; } /* * Get the next event. */ value om_notify_next_event(value v_fc) { invalid_argument("FAM not enabled"); return Val_unit; } #endif /* !FAM_ENABLED */ /* * vim:tw=100:ts=4:et:sw=4:cin */ omake-0.10.3/src/clib/fam_win32.c0000644000175000017500000003724313177364666015000 0ustar gerdgerd/* * Implement a FAM-like service for Win32. * This uses the ReadDirectoryChangesW function, which is * available only on NT+. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004-2006 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey @email{jyh@cs.caltech.edu} * Modified By: Aleksey Nogin @email{nogin@metaprl.org} * @end[license] */ #ifdef WIN32 #ifdef FAM_ENABLED /* Disable some of the warnings */ #pragma warning( disable : 4127 4996 ) #ifndef _WIN32_WINNT #define _WIN32_WINNT 0x0400 #endif #include #include #include #include #include "lm_compat_win32.h" #include "fam_pseudo.h" /* * The events we want to watch for. */ #define FILE_CHANGES (FILE_NOTIFY_CHANGE_FILE_NAME\ | FILE_NOTIFY_CHANGE_SIZE\ | FILE_NOTIFY_CHANGE_LAST_WRITE\ | FILE_NOTIFY_CHANGE_CREATION) /* * Size of the event buffer. This is the maximum size we can * use without getting errors on SMB volumes. */ #define NOTIFY_BUFFER_SIZE (1 << 16) /* * Max utility. */ #define MAX(i, j) ((i) < (j) ? (j) : (i)) static char *code_names[] = { "No Code", "Changed", "Deleted", "StartExecuting", "StopExecuting", "Created", "Moved", "Acknowledge", "Exists", "EndExist" }; /* * Unique identifiers. */ static int id_counter; /* * Info for each directory. * We keep a request number, for compatibility * with Unix FAM. */ typedef struct dir_info { unsigned request; // Request number unsigned recursive; // Is the request recursive unsigned running; // Is this entry running or suspended? HANDLE handle; // Directory handle char buffer[NOTIFY_BUFFER_SIZE]; // Event buffer OVERLAPPED overlapped; // For asynchronous IO void *userdata; // User data for this directory char name[1]; // Name of the directory } DirInfo; /* * Error codes. */ int FAMErrno = 0; char *FamErrlist[] = { "FAM: No Error", "FAM: Too many directories", "FAM: Directory does not exist", "FAM: Windows error", "FAM: Out of memory", "FAM: Bad request number", "FAM: Request already exists", "FAM: Not implemented" }; /************************************************************************ * LOCAL FUNCTIONS */ /* * Close a directory entry. */ static void free_dir(DirInfo *dir) { CloseHandle(dir->overlapped.hEvent); CloseHandle(dir->handle); free(dir); } /* * Free an event. */ static void free_event(FAMEvent *event) { free(event); } /* * Print an error message. */ static void print_error_code(const char *name, DWORD code) { LPTSTR buffer; FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, // Format flags NULL, // Location of the message code, // Error code MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), // Language (LPTSTR) &buffer, // Message buffer 0, // Buffer size NULL); // Arguments /* Print the message */ fprintf(stderr, "%s: failed with code %d: %s\n", name, errno, buffer); fflush(stderr); LocalFree(buffer); } static void print_error(const char *name) { print_error_code(name, GetLastError()); } /* * Start monitoring a directory. */ static void monitor_start(DirInfo *dir) { BOOL code; #ifdef FAM_DEBUG fprintf(stderr, "Monitoring directory %s\n", dir->name); fflush(stderr); #endif code = ReadDirectoryChangesW(dir->handle, // Directory dir->buffer, // Result buffer sizeof(dir->buffer), dir->recursive, // Monitor subdirectories? FILE_CHANGES, // Monitor the standard changes NULL, // Return length is ignored for async IO &dir->overlapped, // Use asynchronous IO NULL); // Completion routine, we'll poll for results if(code == 0) print_error("ReadDirectoryChangesW"); } /* * Wait for an event to happen. */ static int monitor_wait(FAMConnection *fc, DWORD interval) { HANDLE handles[MAX_DIR_COUNT]; unsigned map[MAX_DIR_COUNT]; unsigned i, ncount; DirInfo *dir; DWORD status; DWORD code; /* Make an array of the events to wait on */ ncount = 0; for(i = 0; i != fc->dir_count; i++) { dir = fc->dirs[i]; if(dir && dir->running) { handles[ncount] = dir->overlapped.hEvent; map[ncount] = i; ncount++; } } /* * Now wait for an event * * The enter/leave_blocking_section is performed in * omake_cnotify.c now. */ // enter_blocking_section(); status = WaitForMultipleObjects(ncount, handles, FALSE, interval); if(status == WAIT_FAILED) code = GetLastError(); // leave_blocking_section(); /* Return the index of the event */ if(status >= WAIT_OBJECT_0 && status < WAIT_OBJECT_0 + ncount) status = map[status - WAIT_OBJECT_0]; else if(status >= WAIT_ABANDONED_0 && status < WAIT_ABANDONED_0 + ncount) status = map[status - WAIT_ABANDONED_0]; else { #ifdef FAM_DEBUG fprintf(stderr, "WaitForMultipleObjects: status=%d ncount=%d\n", status, ncount); print_error_code("WaitForMultipleObjects", code); #endif status = WAIT_FAILED; } #ifdef FAM_DEBUG fprintf(stderr, "Woke up on request %d\n", status); fflush(stderr); #endif return (status == WAIT_FAILED ? -1 : 0); } /* * Create events from the completed monitor. */ static void monitor_read(FAMConnection *fc, unsigned request) { const FILE_NOTIFY_INFORMATION *info; unsigned dir_length, name_length, i; char name[NAME_MAX]; char *buffer; FAMEvent *event; FAMCodes fam_code; DirInfo *dir; DWORD length; BOOL code; /* Get the result */ length = 0; dir = fc->dirs[request]; code = GetOverlappedResult(dir->handle, // Directory &dir->overlapped, // Overlapped result &length, // Number of bytes transfered FALSE); // Do not wait /* Add the events */ if(code && length) { buffer = dir->buffer; while(1) { info = (const FILE_NOTIFY_INFORMATION *) buffer; /* Get the action */ switch(info->Action) { case FILE_ACTION_ADDED: fam_code = FAMCreated; break; case FILE_ACTION_REMOVED: fam_code = FAMDeleted; break; case FILE_ACTION_MODIFIED: fam_code = FAMChanged; break; case FILE_ACTION_RENAMED_OLD_NAME: fam_code = FAMDeleted; break; case FILE_ACTION_RENAMED_NEW_NAME: fam_code = FAMCreated; break; default: fam_code = FAMCreated; break; } /* Get the long name */ dir_length = strlen(dir->name); name_length = info->FileNameLength / 2; length = dir_length + name_length + 2; if(length < NAME_MAX) { strcpy(name, dir->name); name[dir_length] = '\\'; for(i = 0; i != name_length; i++) name[dir_length + i + 1] = (char) info->FileName[i]; name[length - 1] = 0; /* Create the event struct */ event = (FAMEvent *) malloc(sizeof(*event)); if(event) { event->fc = fc; event->fr.reqnum = dir->request; event->userdata = dir->userdata; event->code = fam_code; event->next = 0; if(CompatGetLongPathName(name, event->filename, NAME_MAX) == 0) strcpy(event->filename, name); if(fc->last) fc->last = fc->last->next = event; else fc->event = fc->last = event; } } /* Go to the next record */ if(info->NextEntryOffset) buffer += info->NextEntryOffset; else break; } } /* Restart the monitor */ if(dir->running) monitor_start(dir); } /* * Monitor a directory. * The request may be recursive. */ static int monitor_directory(FAMConnection *fc, const char *name, FAMRequest *requestp, void *userdata, int recursive) { HANDLE dir_handle, change_handle; unsigned request, length; DirInfo *dir; #ifdef FAM_DEBUG fprintf(stderr, "Asking to monitor directory: %s\n", name); fflush(stderr); #endif /* Search for a slot */ for(request = 0; request != fc->dir_count; request++) { if(fc->dirs[request] == 0) break; } /* Watch for overflows */ if(request == MAX_DIR_COUNT) { FAMErrno = FAM_TOO_MANY_DIRECTORIES; return -1; } requestp->reqnum = request; /* Get a handle to the directory for synchronous operation */ dir_handle = CreateFile(name, GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_DELETE | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OVERLAPPED, NULL); if(dir_handle == INVALID_HANDLE_VALUE) { FAMErrno = FAM_DIRECTORY_DOES_NOT_EXIST; return -1; } /* We will be using asynchronous operations */ change_handle = CreateEvent(NULL, // Default security FALSE, // Auto-reset FALSE, // Initially non-signaled NULL); // No name if(change_handle == INVALID_HANDLE_VALUE) { CloseHandle(dir_handle); FAMErrno = FAM_WINDOWS_ERROR; return -1; } /* Allocate a directory struct */ length = sizeof(DirInfo) + strlen(name); dir = (DirInfo *) malloc(length); if(dir == 0) { CloseHandle(dir_handle); CloseHandle(change_handle); FAMErrno = FAM_OUT_OF_MEMORY; return -1; } memset(dir, 0, length); /* Initialize */ dir->request = request; dir->recursive = recursive; dir->running = 1; dir->handle = dir_handle; dir->overlapped.hEvent = change_handle; dir->userdata = userdata; strcpy(dir->name, name); /* Save it in the fc */ fc->dirs[request] = dir; fc->dir_count = MAX(request + 1, fc->dir_count); /* Start polling */ monitor_start(dir); return 0; } /************************************************************************ * Public functions. */ /* * Open the server. */ int FAMOpen(FAMConnection *fc) { memset(fc, 0, sizeof(*fc)); fc->id = ++id_counter; return 0; } /* * Close the fc. */ int FAMClose(FAMConnection *fc) { FAMEvent *event, *next; unsigned i; /* Free all the directories */ for(i = 0; i != fc->dir_count; i++) free_dir(fc->dirs[i]); /* Free all the events */ event = fc->event; while(event) { next = event->next; free_event(event); event = next; } /* Reset the fc */ memset(fc, 0, sizeof(*fc)); return 0; } /* * Monitor a directory. */ int FAMMonitorDirectory(FAMConnection *fc, const char *name, FAMRequest *requestp, void *userdata) { return monitor_directory(fc, name, requestp, userdata, 0); } int FAMMonitorDirectoryTree(FAMConnection *fc, const char *name, FAMRequest *requestp, void *userdata) { return monitor_directory(fc, name, requestp, userdata, 1); } /* * Suspend monitoring. */ int FAMSuspendMonitor(FAMConnection *fc, FAMRequest *requestp) { DirInfo *dir; unsigned request; request = requestp->reqnum; if(request >= fc->dir_count || fc->dirs[request] == 0) { FAMErrno = FAM_BAD_REQUEST_NUMBER; return -1; } dir = fc->dirs[request]; if(dir->running) { CancelIo(dir->handle); dir->running = 0; } return 0; } /* * Resume monitoring. */ int FAMResumeMonitor(FAMConnection *fc, FAMRequest *requestp) { DirInfo *dir; unsigned request; request = requestp->reqnum; if(request >= fc->dir_count || fc->dirs[request] == 0) { FAMErrno = FAM_BAD_REQUEST_NUMBER; return -1; } dir = fc->dirs[request]; if(dir->running == 0) { dir->running = 1; monitor_start(dir); } return 0; } /* * Cancel monitoring. */ int FAMCancelMonitor(FAMConnection *fc, FAMRequest *requestp) { DirInfo *dir; unsigned request; request = requestp->reqnum; if(request >= fc->dir_count || fc->dirs[request] == 0) { FAMErrno = FAM_BAD_REQUEST_NUMBER; return -1; } dir = fc->dirs[request]; free_dir(dir); fc->dirs[request] = 0; return 0; } /* * Get the next event. */ int FAMNextEvent(FAMConnection *fc, FAMEvent *event) { FAMEvent *current; int request; while(1) { /* See if there is already an event */ current = fc->event; if(current) { #if FAM_DEBUG fprintf(stderr, "Request: %d, Name: %s, Event: %s\n", current->fr.reqnum, current->filename, code_names[current->code]); fflush(stderr); #endif *event = *current; fc->event = current->next; if(fc->event == 0) fc->last = 0; free_event(current); return 0; } /* If not, wait for an event */ request = monitor_wait(fc, INFINITE); if(request < 0) return -1; monitor_read(fc, request); } } /* * See if there is a pending event. */ int FAMPending(FAMConnection *fc) { int request; while(1) { /* See if there is already an event */ if(fc->event) return 1; /* If not, poll for input */ request = monitor_wait(fc, 0); if(request < 0) return 0; monitor_read(fc, request); } } #endif /* FAM_ENABLED */ #endif /* WIN32 */ omake-0.10.3/src/clib/lm_channel.c0000644000175000017500000000533313177364666015306 0ustar gerdgerd/* * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004 Mojave group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] */ #include #include #include #include #include #include #ifdef WIN32 //#include #include "caml/unixsupport.h" /* * Utilities for pipes, used by Omake_channel. * Returns true if the pipe has available input. */ value omake_shell_peek_pipe(value v_fd) { HANDLE pipe; BOOL status; DWORD total; pipe = Handle_val(v_fd); status = PeekNamedPipe(pipe, NULL, // Buffer for output data 0, // Size of the buffer NULL, // Number of bytes read &total, // Total number of bytes available NULL); // Number of bytes in the next message if(status == 0) failwith("Not a pipe"); return total ? Val_int(1) : Val_int(0); } /* * Figure out what kind of file descriptor this is. * 0: File * 1: Pipe * 2: Socket */ value omake_shell_pipe_kind(value v_fd) { HANDLE pipe; BOOL status; if(Descr_kind_val(v_fd) == KIND_SOCKET) return Val_int(2); pipe = Handle_val(v_fd); status = GetNamedPipeInfo(pipe, NULL, NULL, NULL, NULL); return status ? Val_int(1) : Val_int(0); } #else /* WIN32 */ value omake_shell_peek_pipe(value v_fd) { failwith("omake_shell_peek_pipe: not available on Unix systems"); return Val_unit; } value omake_shell_pipe_kind(value v_fd) { /* Always treat like sockets */ return Val_int(2); } #endif /* WIN32 */ omake-0.10.3/src/clib/fam_kqueue.c0000644000175000017500000003517313177364666015335 0ustar gerdgerd/* * This implements a FAM-like service for systems that support the FreeBSD * kqueue interface. In particular, this has been tested on Mac OS X 10.3. * * Here's the basic design: * We keep an array of DirInfo pointers. When the client requests a dir to * be monitored, we find a free slot and allocate a DirInfo for it. We then * create a kevent_t to monitor that directory, storing a pointer to its * DirInfo as its userdata. * * When we retrieve an event, we turn it into one or more FAMEvents, putting * each new event on a per-FAMConnection queue * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004 Nathaniel Gray, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Nathaniel Gray * @email{n8gray@cs.caltech.edu} * @end[license] */ #ifdef FAM_KQUEUE #include #include #include #include #include #include #include #include #include #ifdef HAVE_STRING_H #include #else /* HAVE_STRING_H */ #ifdef HAVE_STRINGS_H #include #endif /* HAVE_STRINGS_H */ #endif /* HAVE_STRING_H */ #include "fam_pseudo.h" /* * The events we want to watch for. * * Monitoring a directory foo containing bar * When I do: I get flags: * create bar NOTE_ATTRIB NOTE_WRITE * edit bar & save NOTE_ATTRIB NOTE_WRITE * rm -f bar NOTE_ATTRIB NOTE_WRITE * chmod 000 bar * touch existing bar * edit bar via link * rm -rf foo NOTE_DELETE * mv foo floo NOTE_RENAME * chmod 000 foo NOTE_ATTRIB * unmount the fs NOTE_REVOKE * * I guess we'll just look for writes for now. */ #define MON_FLAGS (NOTE_WRITE) /* | NOTE_DELETE | NOTE_RENAME | NOTE_REVOKE | NOTE_ATTRIB) | NOTE_EXTEND | NOTE_LINK */ /* Any write to the directory means a file within changed */ #define MEMBER_CHANGED_FLAGS NOTE_WRITE /* * The mode for opening monitored directories. Someday maybe we can do * this without even needing read perms. */ #define DIR_OPEN_FLAGS O_RDONLY /* * Max utility. */ #define MAX(i, j) ((i) < (j) ? (j) : (i)) #if FAM_DEBUG static char *code_names[] = { "No Code", "Changed", "Deleted", "StartExecuting", "StopExecuting", "Created", "Moved", "Acknowledge", "Exists", "EndExist", "DirectoryChanged" }; #endif typedef struct kevent kevent_t; /* * Info for each directory. * We keep a request number, for compatibility * with Unix FAM. */ typedef struct dir_info { unsigned request; // Request number unsigned running; // Is this entry running or suspended? int handle; // Directory handle void *userdata; // User data for this directory kevent_t *kevent; char name[1]; // Name of the directory } DirInfo; int FAMErrno = 0; char *FamErrlist[] = { "No Error", "Too many directories", "Directory does not exist", "Windows error", "Out of memory", "Bad request number", "Request already exists", "Not implemented", "Permission denied", "Unknown error" }; /* We need a "zero" timespec for specifying non-blocking kevent calls */ static struct timespec gTime0; /************************************************************************ * LOCAL FUNCTIONS */ /* * Close a directory entry. */ static void free_dir(DirInfo *dir) { close(dir->handle); if(dir->kevent) free(dir->kevent); free(dir); } /* * Free a FAM event. */ static void free_fevent(FAMEvent *event) { free(event); } /* * Allocate a kevent */ static kevent_t *new_kevent() { kevent_t *ev; ev = (kevent_t *)malloc(sizeof(kevent_t)); if (ev) memset(ev, 0, sizeof(*ev)); return ev; } #if defined(__NetBSD__) typedef intptr_t kqueue_udata_t; #else typedef void *kqueue_udata_t; #endif /* * Start monitoring a directory. * We store the DirInfo pointer as the userdata in the kevent. */ static int monitor_start(FAMConnection *fc, DirInfo *dir) { int code; kevent_t *kev; #ifdef FAM_DEBUG fprintf(stderr, "Monitoring directory %s\n", dir->name); fflush(stderr); #endif code = -1; if ((kev = new_kevent())) { dir->kevent = kev; /* Register interest in the MON_FLAGS flags of the dir */ EV_SET(kev, dir->handle, EVFILT_VNODE, EV_ADD | EV_CLEAR, MON_FLAGS, (intptr_t) NULL, (kqueue_udata_t) dir); code = kevent(fc->id, kev, 1, NULL, 0, &gTime0); #ifdef FAM_DEBUG fprintf(stderr, " Directory id: %d\n" " kevent code: %d\n", dir->handle, code); fflush(stderr); #endif } if(code < 0) { if(kev) { free(kev); dir->kevent = NULL; } perror("monitor_start"); } return code; } /* Put the new event at the tail end of the queue */ static int add_famevent_of_kevent( FAMConnection *fc, kevent_t *kev, FAMCodes fcode ) { DirInfo *dir_info; FAMEvent *fevent; fevent = (FAMEvent *)malloc(sizeof(FAMEvent)); if(!fevent) return 0; dir_info = (DirInfo *)kev->udata; fevent->fc = fc; fevent->fr.reqnum = dir_info->request; fevent->code = fcode; fevent->userdata = dir_info->userdata; fevent->next = NULL; if( NULL != fc->last ) { fc->last->next = fevent; } else { fc->event = fevent; } fc->last = fevent; strncpy(fevent->filename, dir_info->name, NAME_MAX); return 1; } /* * Poll for an event and put any on the fc->event list */ static int poll_kevent(FAMConnection *fc, struct timespec *timeptr) { int result; kevent_t *kev; #ifdef FAM_DEBUG fprintf(stderr, "Polling FAM Connection\n"); fflush(stderr); #endif if ((kev = new_kevent())) { result = kevent( fc->id, NULL, 0, kev, 1, timeptr ); if(result == 0) { free(kev); return 0; } else if(result < 0) { free(kev); switch(errno) { case EACCES: FAMErrno = FAM_PERMISSION_DENIED; break; case ENOMEM: FAMErrno = FAM_OUT_OF_MEMORY; break; default: FAMErrno = FAM_UNKNOWN_ERROR; }; return -1; } /* Convert each possible event flag to a FAM event */ if(kev->fflags & MEMBER_CHANGED_FLAGS) { if (add_famevent_of_kevent( fc, kev, FAMDirectoryChanged ) == 0) goto poll_error; }; if(kev->fflags & NOTE_DELETE) { if (add_famevent_of_kevent( fc, kev, FAMDeleted ) == 0) goto poll_error; }; if(kev->fflags & NOTE_RENAME) { if (add_famevent_of_kevent( fc, kev, FAMMoved ) == 0) goto poll_error; }; if(kev->fflags & NOTE_REVOKE) { /* Lost access */ if (add_famevent_of_kevent( fc, kev, FAMDeleted ) == 0) goto poll_error; }; if(kev->fflags & NOTE_ATTRIB) { if (add_famevent_of_kevent( fc, kev, FAMChanged ) == 0) goto poll_error; }; free(kev); return 1; poll_error: free(kev); } FAMErrno = FAM_OUT_OF_MEMORY; return -1; } /************************************************************************ * Public functions. */ /* * Open the server. */ int FAMOpen(FAMConnection *fc) { int id; #ifdef FAM_DEBUG fprintf(stderr, "Opening FAM Connection\n"); fflush(stderr); #endif memset(&gTime0, 0, sizeof(struct timespec)); memset(fc, 0, sizeof(*fc)); id = kqueue(); #ifdef FAM_DEBUG fprintf(stderr, "kqueue file descriptor: %d\n", id); fflush(stderr); #endif if (id < 0) return -1; else { fc->id = id; return 0; } } /* * Close the fc. */ int FAMClose(FAMConnection *fc) { FAMEvent *event, *next; unsigned i; /* Free all the directories */ for(i = 0; i != fc->dir_count; i++) if(fc->dirs[i]) free_dir(fc->dirs[i]); /* Free all the events */ event = fc->event; while(event) { next = event->next; free_fevent(event); event = next; } /* Reset the fc */ close(fc->id); memset(fc, 0, sizeof(*fc)); return 0; } /* * Monitor a directory. */ int FAMMonitorDirectory(FAMConnection *fc, const char *name, FAMRequest *requestp, void *userdata) { int dir_handle; unsigned request, length; DirInfo *dir; #ifdef FAM_DEBUG fprintf(stderr, "Asking to monitor directory: %s\n", name); fflush(stderr); #endif /* Search for a slot */ for(request = 0; request != fc->dir_count; request++) { if(fc->dirs[request] == 0) break; } /* Watch for overflows */ if(request == MAX_DIR_COUNT) { FAMErrno = FAM_TOO_MANY_DIRECTORIES; return -1; } requestp->reqnum = request; /* Get a descriptor for the directory */ dir_handle = open(name, DIR_OPEN_FLAGS, 0); if(dir_handle < 0) { /* This is potentially bogus. It could be any number of things. */ FAMErrno = FAM_DIRECTORY_DOES_NOT_EXIST; return -1; } /* Allocate a directory struct */ length = sizeof(DirInfo) + strlen(name); dir = (DirInfo *) malloc(length); if(dir == 0) { close(dir_handle); FAMErrno = FAM_OUT_OF_MEMORY; return -1; } memset(dir, 0, length); /* Initialize */ dir->request = request; dir->running = 1; dir->handle = dir_handle; dir->userdata = userdata; strcpy(dir->name, name); /* Save it in the fc */ fc->dirs[request] = dir; fc->dir_count = MAX(request + 1, fc->dir_count); /* Start monitoring */ monitor_start(fc, dir); return 0; } /* * Cancel monitoring. */ int FAMCancelMonitor(FAMConnection *fc, FAMRequest *requestp) { DirInfo *dir; unsigned request; kevent_t *kev; request = requestp->reqnum; if(request >= fc->dir_count || fc->dirs[request] == 0) { FAMErrno = FAM_BAD_REQUEST_NUMBER; return -1; } dir = fc->dirs[request]; kev = dir->kevent; kev->flags = EV_DELETE; if (kevent(fc->id, kev, 1, NULL, 0, &gTime0) < 0) perror("FAMCancelMonitor"); free_dir(dir); fc->dirs[request] = 0; return 0; } /* * Get the next event. Block for one if there is no event. */ int FAMNextEvent(FAMConnection *fc, FAMEvent *event) { FAMEvent *current; int request; while(1) { /* See if there is already an event */ current = fc->event; if(current) { #if FAM_DEBUG fprintf(stderr, "Request: %d, Name: %s, Event: %s\n", current->fr.reqnum, current->filename, code_names[current->code]); fflush(stderr); #endif *event = *current; fc->event = current->next; if(fc->event == NULL) fc->last = NULL; free_fevent(current); return 0; } /* If not, blocking poll for an event */ #if FAM_DEBUG fprintf( stderr, "FAMNextEvent: polling...\n" ); #endif request = poll_kevent(fc, NULL); #if FAM_DEBUG fprintf( stderr, "FAMNextEvent: request = %d\n", request ); #endif if(request < 0) return -1; } } /* * See if there is a pending event. */ int FAMPending(FAMConnection *fc) { int result; #ifdef FAM_DEBUG fprintf(stderr, "Checking for pending FAM events.\n"); fflush(stderr); #endif /* See if there is already an event */ if(fc->event) return 1; /* If not, non-blocking poll for input */ result = poll_kevent( fc, &gTime0 ); if(result == 0) return 0; else if(result < 0) return -1; return 1; } /***************************************************************************** * Functions from the FAM interface that aren't implemented * The first two probably work, but they've never been tested. */ /* * Suspend monitoring. */ int FAMSuspendMonitor(FAMConnection *fc, FAMRequest *requestp) { #if 0 DirInfo *dir; unsigned request; int code = 0; request = requestp->reqnum; if(request >= fc->dir_count || fc->dirs[request] == 0) { FAMErrno = FAM_BAD_REQUEST_NUMBER; return -1; } dir = fc->dirs[request]; if(dir->running) { kevent_t *kev = dir->kevent; kev->flags = EV_DISABLE; if (kevent(fc->id, kev, 1, NULL, 0, &gTime0) < 0) perror("FAMSuspendMonitor"); dir->running = 0; } return 0; #else FAMErrno = FAM_NOT_IMPLEMENTED; return -1; #endif } /* * Resume monitoring. */ int FAMResumeMonitor(FAMConnection *fc, FAMRequest *requestp) { #if 0 DirInfo *dir; unsigned request; int code = 0; request = requestp->reqnum; if(request >= fc->dir_count || fc->dirs[request] == 0) { FAMErrno = FAM_BAD_REQUEST_NUMBER; return -1; } dir = fc->dirs[request]; if(!(dir->running)) { kevent_t *kev = dir->kevent; kev->flags = EV_ENABLE; if (kevent(fc->id, kev, 1, NULL, 0, &gTime0) < 0) perror("FAMResumeMonitor"); dir->running = 1; } return 0; #else FAMErrno = FAM_NOT_IMPLEMENTED; return -1; #endif } /* This is not supposed to be called on kqueue systems */ int FAMMonitorDirectoryTree(FAMConnection *fc, const char *name, FAMRequest *request, void *userdata) { FAMErrno = FAM_NOT_IMPLEMENTED; return -1; } #else /* FAM_KQUEUE */ #if defined(WIN32) || defined(_WIN32) /* Disable the "translation unit is empty" warning */ #pragma warning( disable : 4206 ) #endif #endif /* FAM_KQUEUE */ omake-0.10.3/src/clib/lm_terminfo.c0000644000175000017500000000425613177364666015524 0ustar gerdgerd/* * Simple Terminfo Interface for ML * Copyright(c) 2002 Justin David Smith, Caltech */ #include #include #include #include #ifdef WIN32 # pragma warning (disable: 4127 4189 4702 4996) #endif #ifdef WIN32 #include #else #include #endif #ifdef NCURSES /* Headers that are readline-specific must be included here. */ #include #ifdef TERMH_IN_NCURSES # include #else # include #endif static int loaded_terminfo = 0; static int load_terminfo() { /* Check to see if we already loaded the terminal data */ if(loaded_terminfo) return(0); /* We haven't loaded anything yet (or we had an error). */ if(setupterm(NULL, 1, NULL) == OK) { /* We were successful! */ loaded_terminfo = 1; return(0); } /* Failure. */ return(-1); } #endif /* NCURSES support? */ /* * Core Info */ value caml_get_number_of_cores(value unit) { CAMLparam1(unit); #ifdef WIN32 SYSTEM_INFO sysinfo; GetSystemInfo(&sysinfo); CAMLreturn (Val_long(sysinfo.dwNumberOfProcessors)); #else CAMLreturn (Val_long(sysconf(_SC_NPROCESSORS_ONLN))); #endif } /* * Terminfo is enabled only of TERM is defined. */ value caml_tgetstr_enabled(value unit) { CAMLparam1(unit); CAMLreturn(getenv("TERM") ? Val_true : Val_false); } /* * Read the indicated terminfo by string. */ value caml_tgetstr(value id) { CAMLparam1(id); CAMLlocal1(result); char *termdata = NULL; /* Lookup the requested capability name. Note that we only get terminfo if we compiled with readline support; otherwise it will not be linked in. */ #ifdef NCURSES if(load_terminfo() == 0) { termdata = tigetstr(String_val(id)); } #endif /* NCURSES */ /* Note that tigetstr will return either 0 or -1 on error. */ if(termdata == NULL || termdata == (char *)(-1)) { result = copy_string(""); } else { result = copy_string(termdata); /* apparently we're not supposed to free termdata here */ /* TEMP: I cannot find specs on this! */ //free(termdata); } /* Return the result */ CAMLreturn(result); } omake-0.10.3/src/clib/lm_termsize.c0000644000175000017500000000460513177364666015541 0ustar gerdgerd/* * Get terminal size * * ---------------------------------------------------------------- * * Copyright (C) 2000-2006 Mojave Group, Caltech * * 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 2 * 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, write to the Free Software * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. * * Authors: Jason Hickey * Aleksey Nogin */ #include #if defined(__CYGWIN__) || defined(__svr4__) # include #endif #ifdef WIN32 # include # pragma warning (disable: 4127 4189 4702) #else # include # include #endif #include #include #include #include value caml_term_size(value arg) { CAMLparam1(arg); CAMLlocal1(buf); /* Return a pair of numbers */ buf = alloc_small(2, 0); /* Get the terminal size, return None on failure */ #ifdef WIN32 { HANDLE fd = *(HANDLE *)Data_custom_val(arg); CONSOLE_SCREEN_BUFFER_INFO ConsoleInfo; if (! GetConsoleScreenBufferInfo(fd, &ConsoleInfo)) failwith("lm_termsize.c: caml_term_size: GetConsoleScreenBufferInfo failed"); Field(buf, 0) = Val_int(ConsoleInfo.dwSize.Y); Field(buf, 1) = Val_int(ConsoleInfo.dwSize.X); } #else /* WIN32 */ #ifdef TIOCGWINSZ { int fd = Int_val(arg); struct winsize ws; if(ioctl(fd, TIOCGWINSZ, &ws) < 0) failwith("lm_termsize.c: caml_term_size: not a terminal"); /* Return the pair of numbers */ Field(buf, 0) = Val_int(ws.ws_row); Field(buf, 1) = Val_int(ws.ws_col); } #else /* TIOCGWINSZ */ /* Assume that the terminal is 80 by 25 */ Field(buf, 0) = Val_int( 25 ); Field(buf, 1) = Val_int( 80 ); #endif /* TIOCGWINSZ */ #endif /* WIN32 */ CAMLreturn(buf); } omake-0.10.3/src/clib/fam_inotify.c0000644000175000017500000002335313177364666015514 0ustar gerdgerd/* * This implements a FAM-like service based on the inotify Linux interface. * For simplicity, we turn this into a FAM-like interface. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2004 Nathaniel Gray, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] */ #ifdef FAM_INOTIFY #include #include #include #include #include #include #include #include #include "fam_pseudo.h" #ifdef HAVE_INOTIFY_H # include #else # error "sys/inotify.h is not found" #endif /* * Max utility. */ #define MAX(i, j) ((i) < (j) ? (j) : (i)) #define MIN(i, j) ((i) < (j) ? (i) : (j)) static char *code_names[] = { "No Code", "Changed", "Deleted", "StartExecuting", "StopExecuting", "Created", "Moved", "Acknowledge", "Exists", "EndExist", "DirectoryChanged" }; int FAMErrno = 0; char *FamErrlist[] = { "No Error", "Too many directories", "Directory does not exist", "Windows error", "Out of memory", "Bad request number", "Request already exists", "Not implemented", "Permission denied", "Unknown error" }; /* * Info for each directory. * We keep a request number, for compatibility * with Unix FAM. */ typedef struct dir_info { unsigned request; // Request number int wd; // Watch descriptor void *userdata; // User data for this directory char name[1]; // Name of the directory } DirInfo; /************************************************************************ * LOCAL FUNCTIONS */ /* * Close a directory entry. */ static void free_dir(DirInfo *dir) { free(dir); } /* * Free an event. */ static void free_event(FAMEvent *event) { free(event); } /* * Events are read directly from the file descriptor. * Use select(2) to check if there is pending input. */ static int monitor_poll(FAMConnection *fc) { fd_set fd_in; struct timeval timeout; timeout.tv_sec = 0; timeout.tv_usec = 0; FD_ZERO(&fd_in); FD_SET(fc->id, &fd_in); select(fc->id + 1, &fd_in, 0, 0, &timeout); return FD_ISSET(fc->id, &fd_in); } /* * The FAM code corresponding to an inotify code. */ static FAMCodes fam_code(int mask) { FAMCodes code; if(mask & (IN_MOVED_FROM | IN_MOVED_TO)) code = FAMMoved; else if(mask & IN_DELETE) code = FAMDeleted; else code = FAMChanged; return code; } static int monitor_read(FAMConnection *fc) { char buf[(sizeof(struct inotify_event) + 64) * 256]; struct inotify_event *ievent; int i, len, amount, rd; FAMEvent *eventp; DirInfo *dirp; /* Try reading multiple events at once */ len = read(fc->id, buf, sizeof(buf)); if(len < 0) { perror ("read"); return -1; } /* Turn each even into a FAM event */ i = 0; while(i < len) { ievent = (struct inotify_event *) &buf[i]; /* Find the directory this belongs to */ for(rd = 0; rd != fc->dir_count; rd++) { dirp = fc->dirs[rd]; if(dirp && dirp->wd == ievent->wd) break; } if(rd == fc->dir_count) { // This wan't happen if things are working correctly fprintf(stderr, "Inotify: bogus watch descriptor: %d\n", ievent->wd); break; } /* Translate it to a FAM event */ eventp = malloc(sizeof(FAMEvent)); if(eventp == 0) break; eventp->fc = fc; eventp->fr.reqnum = rd; eventp->userdata = dirp->userdata; eventp->code = fam_code(ievent->mask); eventp->next = 0; /* Copy the name */ amount = MIN(NAME_MAX - 1, ievent->len); memcpy(eventp->filename, ievent->name, amount); eventp->filename[amount] = 0; /* Link it in */ if(fc->last == 0) fc->event = fc->last = eventp; else fc->last = fc->last->next = eventp; i += sizeof(struct inotify_event) + ievent->len; } return 0; } /************************************************************************ * Public functions. */ /* * Open the server. */ int FAMOpen(FAMConnection *fc) { int id; memset(fc, 0, sizeof(*fc)); fc->id = inotify_init(); if(fc ->id < 0) perror("inotify_init"); return fc->id; } /* * Close the fc. */ int FAMClose(FAMConnection *fc) { FAMEvent *event, *next; int i; /* Free all the directories */ for(i = 0; i != MAX_DIR_COUNT; i++) { if(fc->dirs[i]) free_dir(fc->dirs[i]); } /* Free all the events */ event = fc->event; while(event) { next = event->next; free_event(event); event = next; } /* Reset the fc */ close(fc->id); memset(fc, 0, sizeof(*fc)); return 0; } /* * Monitor a directory. */ int FAMMonitorDirectory(FAMConnection *fc, const char *name, FAMRequest *requestp, void *userdata) { unsigned request, length; DirInfo *dir; int i, wd; #ifdef FAM_DEBUG fprintf(stderr, "Asking to monitor directory: %s\n", name); fflush(stderr); #endif /* Search for a slot */ for(request = 0; request != fc->dir_count; request++) { if(fc->dirs[request] == 0) break; } /* Watch for overflows */ if(request == MAX_DIR_COUNT) { FAMErrno = FAM_TOO_MANY_DIRECTORIES; return -1; } requestp->reqnum = request; /* Add the watch */ wd = inotify_add_watch(fc->id, name, IN_MODIFY | IN_CLOSE_WRITE | IN_MOVED_TO | IN_DELETE | IN_CREATE | IN_ATTRIB); if(wd < 0) { FAMErrno = FAM_DIRECTORY_DOES_NOT_EXIST; return -1; } /* Allocate a directory struct */ length = sizeof(DirInfo) + strlen(name); dir = (DirInfo *) malloc(length); if(dir == 0) { FAMErrno = FAM_OUT_OF_MEMORY; return -1; } memset(dir, 0, length); /* Initialize */ dir->request = request; dir->userdata = userdata; dir->wd = wd; strcpy(dir->name, name); /* Save it in the fc */ fc->dirs[request] = dir; fc->dir_count = MAX(request + 1, fc->dir_count); return 0; } /* * Cancel monitoring. */ int FAMCancelMonitor(FAMConnection *fc, FAMRequest *requestp) { DirInfo *dir; unsigned request; request = requestp->reqnum; if(request >= fc->dir_count || fc->dirs[request] == 0) { FAMErrno = FAM_BAD_REQUEST_NUMBER; return -1; } dir = fc->dirs[request]; inotify_rm_watch(fc->id, dir->wd); free_dir(dir); fc->dirs[request] = 0; return 0; } /* * Get the next event. Block for one if there is no event. */ int FAMNextEvent(FAMConnection *fc, FAMEvent *event) { FAMEvent *current; int request; while(1) { /* See if there is already an event */ current = fc->event; if(current) { #if FAM_DEBUG fprintf(stderr, "Request: %d, Name: %s, Event: %s\n", current->fr.reqnum, current->filename, code_names[current->code]); fflush(stderr); #endif *event = *current; fc->event = current->next; if(fc->event == NULL) fc->last = NULL; free_event(current); return 0; } /* If not, blocking poll for an event */ #if FAM_DEBUG fprintf( stderr, "FAMNextEvent: blocking...\n" ); #endif request = monitor_read(fc); #if FAM_DEBUG fprintf( stderr, "FAMNextEvent: request = %d\n", request ); #endif if(request < 0) return -1; } } /* * See if there is a pending event. */ int FAMPending(FAMConnection *fc) { int result; #ifdef FAM_DEBUG fprintf(stderr, "Checking for pending FAM events.\n"); fflush(stderr); #endif /* See if there is already an event */ if(fc->event) return 1; /* If not, non-blocking poll for input */ return monitor_poll(fc); } /***************************************************************************** * Functions from the FAM interface that aren't implemented * The first two probably work, but they've never been tested. */ /* * Suspend monitoring. */ int FAMSuspendMonitor(FAMConnection *fc, FAMRequest *requestp) { FAMErrno = FAM_NOT_IMPLEMENTED; return -1; } /* * Resume monitoring. */ int FAMResumeMonitor(FAMConnection *fc, FAMRequest *requestp) { FAMErrno = FAM_NOT_IMPLEMENTED; return -1; } int FAMMonitorDirectoryTree(FAMConnection *fc, const char *name, FAMRequest *requestp, void *userdata) { FAMErrno = FAM_NOT_IMPLEMENTED; return -1; } #else /* FAM_INOTIFY */ #if defined(WIN32) || defined(_WIN32) /* Disable the "translation unit is empty" warning */ #pragma warning( disable : 4206 ) #endif #endif /* FAM_INOTIFY */ omake-0.10.3/src/clib/lm_uname_ext.c0000644000175000017500000001057213177364666015664 0ustar gerdgerd/* * System info. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2003 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] */ #include #include #include #include #include #ifdef WIN32 #include /* Disable some of the warnings */ #pragma warning( disable : 4127 4189 4702 4996 ) /* * Fake utsname. */ struct utsname { char sysname[1024]; char nodename[1024]; char release[1024]; char version[1024]; char machine[1024]; }; /* * uname is undefined as far as I know (jyh). * Get most of the info from the environment. */ static int uname(struct utsname *name) { DWORD len; SYSTEM_INFO sysinfo; OSVERSIONINFO osversion; unsigned ptype; char *osname; /* Ask Win32 for OS info */ osversion.dwOSVersionInfoSize = sizeof(osversion); if(GetVersionEx(&osversion) == 0) return -1; /* String version of the osname */ osname = (char *) "unknown"; switch (osversion.dwPlatformId) { case VER_PLATFORM_WIN32s: osname = (char *) "win32s"; break; case VER_PLATFORM_WIN32_WINDOWS: switch (osversion.dwMinorVersion) { case 0: osname = (char *) "Win95"; break; case 1: osname = (char *) "Win98"; break; default: osname = (char *) "Win9X"; break; } break; case VER_PLATFORM_WIN32_NT: osname = (char *) "WinNT"; break; } /* Collect data */ strcpy(name->sysname, osname); sprintf(name->version, "%d.%d", (int) osversion.dwMajorVersion, (int) osversion.dwMinorVersion); sprintf(name->release, "%d %s", (int) osversion.dwBuildNumber, osversion.szCSDVersion); /* Computer name */ len = sizeof(name->nodename) - 1; GetComputerNameA(name->nodename, &len); name->nodename[len] = 0; /* Machine */ GetSystemInfo(&sysinfo); /* CPU type */ switch (sysinfo.wProcessorArchitecture) { case PROCESSOR_ARCHITECTURE_INTEL: if(sysinfo.dwProcessorType < 3) /* Shouldn't happen. */ ptype = 3; else if(sysinfo.dwProcessorType > 9) /* P4 */ ptype = 6; else ptype = sysinfo.dwProcessorType; sprintf(name->machine, "i%d86", ptype); break; case PROCESSOR_ARCHITECTURE_ALPHA: strcpy(name->machine, "alpha"); break; case PROCESSOR_ARCHITECTURE_MIPS: strcpy(name->machine, "mips"); break; default: strcpy(name->machine, "unknown"); break; } return 0; } #else /* WIN32 */ #include #endif /* !WIN32 */ /* * Allocate a 5-tuple of strings. */ value lm_uname(value x) { CAMLparam1(x); CAMLlocal1(result); struct utsname name; /* Get sysinfo */ if(uname(&name) < 0) failwith("uname"); /* Copy data */ result = alloc_tuple(5); Field(result, 0) = Val_unit; Field(result, 1) = Val_unit; Field(result, 2) = Val_unit; Field(result, 3) = Val_unit; Field(result, 4) = Val_unit; Field(result, 0) = copy_string(name.sysname); Field(result, 1) = copy_string(name.nodename); Field(result, 2) = copy_string(name.release); Field(result, 3) = copy_string(name.version); Field(result, 4) = copy_string(name.machine); /* Return it */ CAMLreturn(result); } omake-0.10.3/src/clib/lm_unix_cutil.c0000644000175000017500000002621313177364666016061 0ustar gerdgerd #include #include #include #include #include #include #include #include #if defined(WIN32) || defined(_WIN32) /* Disable some of the warnings */ #pragma warning( disable : 4100 4201 4127 4189 4702 4716 4996 ) #endif /* * Lock codes. */ #define LM_LOCK_UN 0 #define LM_LOCK_SH 1 #define LM_LOCK_EX 2 #define LM_LOCK_TSH 3 #define LM_LOCK_TEX 5 #define FLOCK_LEN ((unsigned int) ~0 >> 2) CAMLprim value caml_eff_string_compare(value s1, value s2) { mlsize_t len1, len2; if (s1 == s2) return Val_int(0); len1 = caml_string_length(s1); len2 = caml_string_length(s2); if(len1 == len2) { return memcmp(String_val(s1), String_val(s2), len1); } else if(len1 > len2) { return Val_int(1); } else { return Val_int(-1); } } /* * Print the stack pointer for debugging. */ #if 0 value lm_print_stack_pointer(value v_arg) { int sp; fprintf(stderr, "Stack pointer: 0x%08lx\n", (unsigned long) &sp); return Val_unit; } #endif #ifdef WIN32 #include #include #include #include "lm_compat_win32.h" /* * File descriptor. */ value int_of_fd(value fd) { return Val_long((intnat) *(HANDLE *)Data_custom_val(fd)); } /* * Home directory on Win32. */ value home_win32(value v_unit) { CAMLparam1(v_unit); TCHAR path[MAX_PATH]; if(SUCCEEDED(CompatSHGetFolderPath(NULL, CSIDL_LOCAL_APPDATA | CSIDL_FLAG_CREATE, NULL, 0, path))) CAMLreturn(copy_string(path)); failwith("home_win32"); return Val_unit; } /* * File locking. */ #define F_ULOCK 0 #define F_LOCK 1 #define F_TLOCK 2 #define F_TEST 3 #define F_RLOCK 4 #define F_TRLOCK 5 value lockf_win32(value v_fd, value v_kind, value v_len) { HANDLE fd = *(HANDLE *)Data_custom_val(v_fd); int kind = Int_val(v_kind); int len = Int_val(v_len); OVERLAPPED overlapped; int code, flags = 0; DWORD pos, error = 0; /* Get the current position in the file */ pos = SetFilePointer(fd, 0, 0, FILE_CURRENT); /* XXX: HACK: we should probably compute this correctly */ if(len == 0) len = 1; /* Unlock case */ if(kind == F_ULOCK) UnlockFile(fd, pos, 0, len, 0); else { /* Some kind of locking operation */ switch(kind) { case F_LOCK: flags = LOCKFILE_EXCLUSIVE_LOCK; break; case F_TLOCK: flags = LOCKFILE_EXCLUSIVE_LOCK | LOCKFILE_FAIL_IMMEDIATELY; break; case F_RLOCK: flags = 0; break; case F_TRLOCK: flags = LOCKFILE_FAIL_IMMEDIATELY; break; default: invalid_argument("lockf_win32"); break; } /* Set the offset */ memset(&overlapped, 0, sizeof(overlapped)); overlapped.Offset = pos; /* Perform the lock */ enter_blocking_section(); code = LockFileEx(fd, flags, 0, len, 0, &overlapped); if(code == 0) error = GetLastError(); leave_blocking_section(); /* Fail if the lock was not successful */ if(code == 0) { char szBuf[1024]; LPVOID lpMsgBuf; switch(error) { case ERROR_LOCK_FAILED: case ERROR_LOCK_VIOLATION: /* * XXX: HACK: this exception is being caught * Do not change the string w/o changing the wrapper code. */ failwith("lockf_win32: already locked"); break; case ERROR_POSSIBLE_DEADLOCK: /* * XXX: HACK: this exception is being caught * Do not change the string w/o changing the wrapper code. */ failwith("lockf_win32: possible deadlock"); break; default: FormatMessage( FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, NULL, error, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR) &lpMsgBuf, 0, NULL); sprintf(szBuf, "lockf_win32 failed with error %u: %s", error, (char *) lpMsgBuf); LocalFree(lpMsgBuf); failwith(szBuf); break; } } } return Val_unit; } /* * Translate flock operators. */ static int lockf_of_flock[] = { F_ULOCK, F_RLOCK, F_LOCK, F_TRLOCK, F_TLOCK }; /* * flock wrapper. */ value lm_flock(value v_fd, value v_op) { value v_kind; v_kind = Val_int(lockf_of_flock[Int_val(v_op)]); return lockf_win32(v_fd, v_kind, Val_int(FLOCK_LEN)); } /* * Truncate to the current position. */ value ftruncate_win32(value v_fd) { HANDLE fd = *(HANDLE *)Data_custom_val(v_fd); SetEndOfFile(fd); return Val_unit; } /************************************************************************ * Registry. */ /* * Get the value of a registry key. */ value caml_registry_find(value v_hkey, value v_subkey, value v_field) { char buffer[8192]; const char *subkey, *field; DWORD len; LONG code; HKEY hkey = 0; /* Get the arguments */ switch(Int_val(v_hkey)) { case 0: hkey = HKEY_CLASSES_ROOT; break; case 1: hkey = HKEY_CURRENT_CONFIG; break; case 2: hkey = HKEY_CURRENT_USER; break; case 3: hkey = HKEY_LOCAL_MACHINE; break; case 4: hkey = HKEY_USERS; break; default: caml_failwith("get_registry: unknown handle"); break; } /* Ask Windows */ subkey = String_val(v_subkey); field = String_val(v_field); len = sizeof(buffer); #if 0 code = RegGetValue(hkey, subkey, field, RRF_RT_REG_SZ, NULL, (LPVOID) buffer, &len); if(code != ERROR_SUCCESS) caml_raise_not_found(); #else { HKEY hand; code = RegOpenKeyEx(hkey, subkey, 0, KEY_QUERY_VALUE, &hand); if(code != ERROR_SUCCESS) caml_raise_not_found(); code = RegQueryValueEx(hand, field, NULL, NULL, (LPBYTE) buffer, &len); RegCloseKey(hand); if(code != ERROR_SUCCESS) caml_raise_not_found(); } #endif /* Got the value */ return copy_string(buffer); } #else /* WIN32 */ #include #include #include #include #include #include value int_of_fd(value fd) { return fd; } value home_win32(value v_unit) { caml_failwith("home_win32: not to be used except on Win32"); return Val_unit; } value lockf_win32(value v_fd, value v_kind, value v_len) { caml_failwith("lockf_win32: not to be used except on Win32"); return Val_unit; } value ftruncate_win32(value v_fd) { caml_failwith("ftruncate_current_win32: not to be used except on Win32"); return Val_unit; } value caml_registry_find(value v_key, value v_subkey, value v_field) { caml_raise_not_found(); return Val_unit; } /* * Translations. */ #if defined(LOCK_UN) && defined(LOCK_SH) && defined(LOCK_EX) #define FLOCK_ENABLED static int flock_of_flock[] = { LOCK_UN, LOCK_SH, LOCK_EX, LOCK_SH | LOCK_NB, LOCK_EX | LOCK_NB }; #endif #if !defined(FLOCK_ENABLED) && defined(FCNTL_ENABLED) #if defined(F_RDLCK) && defined(F_WRLCK) && defined(F_UNLCK) && defined(F_SETLK) && defined(F_SETLKW) && defined(SEEK_SET) #define FCNTL_ENABLED static int fcntl_type_of_flock[] = { F_UNLCK, F_RDLCK, F_WRLCK, F_RDLCK, F_WRLCK }; static int fcntl_of_flock[] = { F_SETLKW, F_SETLKW, F_SETLKW, F_SETLK, F_SETLK }; #endif #endif #if !defined(FLOCK_ENABLED) && !defined(FCNTL_ENABLED) && defined(LOCKF_ENABLED) #if defined(F_ULOCK) && defined(F_LOCK) && defined(F_TLOCK) #define LOCKF_ENABLED static int lockf_of_flock[] = { F_ULOCK, F_LOCK, F_LOCK, F_TLOCK, F_TLOCK }; #endif #endif value lm_flock(value v_fd, value v_op) { int fd, op, cmd, code; fd = Int_val(v_fd); op = Int_val(v_op); #if defined(FLOCK_ENABLED) cmd = flock_of_flock[op]; enter_blocking_section(); code = flock(fd, cmd); leave_blocking_section(); #elif defined(FCNTL_ENABLED) { struct flock info; cmd = fcntl_of_flock[op]; info.l_type = fcntl_type_of_flock[op]; info.l_whence = SEEK_SET; info.l_start = 0; info.l_len = FLOCK_LEN; enter_blocking_section(); code = fcntl(fd, cmd, &info); leave_blocking_section(); } #elif defined(LOCKF_ENABLED) cmd = lockf_of_flock[op]; caml_enter_blocking_section(); code = lockf(fd, cmd, FLOCK_LEN); caml_leave_blocking_section(); #else code = -1; #endif if(code < 0) caml_failwith("flock"); return Val_unit; } #endif /* !WIN32 */ /************************************************************************ * Password file (only on Unix). */ #ifdef WIN32 /* * The empty array. */ value lm_getpwents(value v_unit) { return Val_emptylist; } #else /* !WIN32 */ /* * Scan the password file. * type passwd_entry = { pw_name : string; pw_passwd : string; pw_uid : int; pw_gid : int; pw_gecos : string; pw_dir : string; pw_shell : string; } */ value lm_getpwents(value v_unit) { CAMLparam1(v_unit); CAMLlocal3(users, entry, cons); struct passwd *entryp; /* Create a list of users */ users = Val_emptylist; /* Scan the password file */ setpwent(); while((entryp = getpwent())) { entry = caml_alloc_tuple(7); Store_field(entry, 0, caml_copy_string(entryp->pw_name)); Store_field(entry, 1, caml_copy_string(entryp->pw_passwd)); Store_field(entry, 2, Val_int(entryp->pw_uid)); Store_field(entry, 3, Val_int(entryp->pw_gid)); #ifdef __BEOS__ Store_field(entry, 4, copy_string("")); #else Store_field(entry, 4, copy_string(entryp->pw_gecos)); #endif Store_field(entry, 5, copy_string(entryp->pw_dir)); Store_field(entry, 6, copy_string(entryp->pw_shell)); cons = caml_alloc_tuple(2); Store_field(cons, 0, entry); Store_field(cons, 1, users); users = cons; } endpwent(); CAMLreturn(users); } #endif /* !WIN32 */ value lm_getlk(value v_fd, value v_op) { #if defined(FCNTL_ENABLED) int fd, op, code; struct flock info; fd = Int_val(v_fd); op = Int_val(v_op); info.l_type = op; info.l_whence = SEEK_SET; info.l_start = 0; info.l_len = 0; caml_enter_blocking_section(); code = fcntl(fd, F_GETLK, &info); caml_leave_blocking_section(); if (code < 0) { char buf[2048]; sprintf(buf, "lm_getlk error: %i", errno); caml_failwith(buf); } if (info.l_type == F_UNLCK) return Val_int(0); else return Val_int(info.l_pid); #else /* FCNTL_ENABLED */ caml_failwith("lm_getlk: not supported"); #endif /* FCNTL_ENABLED */ } #ifdef HAVE_MONCONTROL extern int moncontrol(int); #endif value lm_moncontrol(value flag) { #ifdef HAVE_MONCONTROL moncontrol(Bool_val(flag)); #endif return Val_unit; } omake-0.10.3/src/clib/lm_fs_case_sensitive.c0000644000175000017500000000713413177364666017373 0ustar gerdgerd/* * Detect the case-sensitivity of a filesystem, when possible * * ------------------------------------------------ * * @begin[license] * Copyright (C) 2007 Mojave Group, Caltech * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation, * version 2.1 of the License. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * * Additional permission is given to link this library with the * OpenSSL project's "OpenSSL" library, and with the OCaml runtime, * and you may distribute the linked executables. See the file * LICENSE.libmojave for more details. * * Author: Nathaniel Gray * @email{n8gray@cs.caltech.edu} * @end[license] */ /* For Caml */ #include #include #include #include #ifdef DETECT_FS_CASE_SENSITIVE_GETATTRLIST /* This is the OS X implementation, using getattrlist. */ /* For statfs */ #include #include /* For getattrlist */ #include #include /* Other various includes */ #include #include typedef struct vol_caps_buf { u_int32_t size; vol_capabilities_attr_t caps; } vol_caps_buf_t; value lm_fs_case_sensitive_available(value _unit) { return Val_true; } /* * Returns true if the volume containing the path is case-sensitive, * or false if it is not. * Raises Failure if the case-sensitivity cannot be detected. */ value lm_fs_case_sensitive(value path_val) { CAMLparam1(path_val); struct statfs stat; char *path = String_val(path_val); do { caml_enter_blocking_section(); if (statfs(path, &stat)) break; struct attrlist alist; memset(&alist, 0, sizeof(alist)); alist.bitmapcount = ATTR_BIT_MAP_COUNT; alist.volattr = ATTR_VOL_CAPABILITIES; vol_caps_buf_t buffer; if (getattrlist(stat.f_mntonname, &alist, &buffer, sizeof(buffer), 0)) break; caml_leave_blocking_section(); if (!(alist.volattr & ATTR_VOL_CAPABILITIES)) caml_failwith("Couldn't get volume capabilities"); if (!(buffer.caps.valid[VOL_CAPABILITIES_FORMAT] & VOL_CAP_FMT_CASE_SENSITIVE)) caml_failwith("VOL_CAP_FMT_CASE_SENSITIVE not valid on this volume"); if (buffer.caps.capabilities[VOL_CAPABILITIES_FORMAT] & VOL_CAP_FMT_CASE_SENSITIVE) { CAMLreturn(Val_true); } else { CAMLreturn(Val_false); } } while (0); caml_leave_blocking_section(); caml_failwith(strerror(errno)); CAMLreturn(Val_false); /* For the compiler's sake */ } #else /* not DETECT_FS_CASE_SENSITIVE_GETATTRLIST */ #ifdef _WIN32 #pragma warning( disable : 4100 ) #endif /* _WIN32 */ value lm_fs_case_sensitive_available(value _unit) { return Val_false; } value lm_fs_case_sensitive(value path_val) { caml_failwith("lm_fs_case_sensitive not supported"); return Val_false; /* For the compiler's sake */ } #endif /* DETECT_FS_CASE_SENSITIVE_GETATTRLIST */ omake-0.10.3/src/top/0000755000175000017500000000000013177364665012726 5ustar gerdgerdomake-0.10.3/src/top/OMakefile0000644000175000017500000000167013177364665014511 0ustar gerdgerd OCAMLINCLUDES+= +compiler-libs top_config.ml: section FP = $(fopen top_config.ml,w) fprintln($(FP), $"" let bootdir = "$(absname $(BOOTDIR))" let builddir = "$(absname $(BUILDDIR))" let include_dirs = let (//) = Filename.concat in [ builddir // "src"// "ast" ; builddir // "src"// "build" ; builddir // "src"// "util" ; builddir // "src"// "builtin" ; builddir // "src"// "clib" ; builddir // "src"// "env" ; builddir // "src"// "eval" ; builddir // "src"// "exec" ; builddir // "src"// "ir" ; builddir // "src"// "libmojave" ; builddir // "src"// "magic" ; builddir // "src"// "main" ; builddir // "src"// "shell" ; ] "") close($(FP)) # OCamlGeneratedFiles(top_config.ml) # Here the order matters which should be fixed later FILES[] = top_config boot_top #.DEFAULT: $(OCamlLibrary boot_repl, $(FILES)) #OCAMLINCLUDES+= $(shell ocamlfind query utop) omake-0.10.3/src/top/boot_printers.ml0000644000175000017500000000017613177364665016155 0ustar gerdgerd open Boot_top;; Topdirs.dir_install_printer Format.std_formatter (Longident.parse "Lm_location.pp_print_location");; omake-0.10.3/src/top/myutop.ml0000644000175000017500000000003313177364665014611 0ustar gerdgerdlet () = UTop_main.main () omake-0.10.3/src/top/boot_top.ml0000644000175000017500000000015013177364665015101 0ustar gerdgerd let () = begin Clflags.include_dirs := Top_config.include_dirs @ !Clflags.include_dirs ; end omake-0.10.3/src/main/0000755000175000017500000000000013177364666013051 5ustar gerdgerdomake-0.10.3/src/main/OMakefile0000644000175000017500000000210413177364665014624 0ustar gerdgerd# # Config # OCAMLINCLUDES[] += ../libmojave ../front ../magic ../ast ../ir ../env ../exec ../eval ../shell ../build ../builtin # # Main programs # FILES[] = omake_main_util omake_shell omake_main OCAML_LIBS[] = ../libmojave/lm ../front/frt ../magic/magic ../ast/ast ../ir/ir ../env/env ../exec/exec ../eval/eval ../shell/shell ../build/build ../builtin/builtin OCAML_CLIBS[] = ../clib/clib MakeOCamlProgram(omake, $(FILES)) osh$(EXE): omake$(EXE) ln-or-cp $< $@ .DEFAULT: omake$(EXE) osh$(EXE) all: omake$(EXE) osh$(EXE) # # Install into the binaries # install: omake$(EXE) osh$(EXE) mkdir -p $(INSTALL_BINDIR) cp -f -m 555 omake$(EXE) $(INSTALL_BINDIR)/ ln-or-cp $(INSTALL_BINDIR)/omake$(EXE) $(INSTALL_BINDIR)/osh$(EXE) clean: $(CLEAN) $(addsuffixes $(array $(EXE), $(string $(EMPTY)), .opt, .run), omake osh) # # Generate a Makefile # MakeOCamlDepend($(FILES), magic.cma) MakeMakefile() # # For the initial boot, just make omake # main: omake$(EXE) omake-0.10.3/src/main/omake_main_util.ml0000644000175000017500000000424013177364665016537 0ustar gerdgerdmodule Pos = Omake_pos.Make (struct let name = "Omake_main_util" end);; let main_remote cwd options targets = (* Set up the environment *) Unix.chdir cwd; Omake_node.Dir.reset_cwd (); let cwd = Omake_node.Dir.cwd () in let exec = Omake_exec.Exec.create cwd options in let cache = Omake_cache.create () in let venv = Omake_env.create options "." exec cache in let venv = Omake_builtin.venv_add_command_defs venv in let venv = Omake_env.venv_add_var venv Omake_var.targets_var (ValString (String.concat " " targets)) in let venv = Omake_builtin.venv_add_builtins venv in (* Shell evaluator *) let pos = Pos.string_exp_pos "main_remote" in let shell = Omake_rule.eval_shell venv pos in Omake_exec_remote.main shell options let print_hash_stats () = Format.eprintf "@[Hash statistics:@ %t@]@." Lm_hash.pp_print_stats let rec search start cwd len i = if i < start then raise (Omake_value_type.OmakeFatal ("can not find " ^ Omake_state.makeroot_name ^ " or " ^ Omake_state.makeroot_short_name)) else if cwd.[i] = '/' || cwd.[i] = '\\' then (* Maybe file is in this directory *) let dir = String.sub cwd 0 i in if Sys.file_exists (Filename.concat dir Omake_state.makeroot_name) || Sys.file_exists (Filename.concat dir Omake_state.makeroot_short_name) then let rest = String.sub cwd (i + 1) (len - i - 1) in dir, rest else search start cwd len (i - 1) else search start cwd len (i - 1) (* * Find the outermost OMakeroot. *) let chroot () = let cwd = try Unix.getcwd () with Unix.Unix_error _ -> Format.eprintf "*** omake: fatal error: current directory does not exist@."; exit 1 in let len = String.length cwd in let start = Lm_filename_util.drive_skip cwd in let dir, rest = if Sys.file_exists (Filename.concat cwd Omake_state.makeroot_name) || Sys.file_exists (Filename.concat cwd Omake_state.makeroot_short_name) then cwd, "." else search start cwd len (len - 1) in if rest <> "." then Format.eprintf "*** omake: changing directory to %s@." dir; Unix.chdir dir; Omake_node.Dir.reset_cwd (); rest omake-0.10.3/src/main/omake_main.ml0000644000175000017500000002016513177364665015506 0ustar gerdgerdlet debug_hash = ref false (* List of targets to build. *) let targets = ref [] let server_flag = ref None let shell_flag = ref false let command_string = ref None let install_flag = ref false let install_subdirs = ref false let install_force = ref false let extended_rusage = ref false (* * Arguments. *) let header = "OMake generic system builder, version " ^ Omake_magic.version let spec = Lm_arg.StrictOptions, (**) Omake_options.( ["Make flags", (**) options_spec; "Output flags", (**) output_spec; "Cache management", (**) ["--save-interval", Lm_arg.Float (fun f -> Omake_build.save_interval := f), (**) (Lm_printf.sprintf "Save the build DB (\".omakedb\") every x seconds (0 disables, default: %F)" (**) Omake_magic.default_save_interval); "--force-dotomake", Lm_arg.Set Omake_state.always_use_dotomake, (**) "Always use $HOME/.omake for .omc cache files"; "--dotomake", Lm_arg.String (fun s -> Omake_state.set_omake_dir s), (**) "Use the specified directory in place of $HOME/.omake"]; "Helper flags", (**) ["--install", Lm_arg.Set install_flag, (**) "Install an OMake project into the current directory"; "--install-all", Lm_arg.SetFold (fun opts b -> install_flag := b; install_subdirs := b; opts), (**) "Install an OMake project into the current directory and all subdirectories"; "--install-force", Lm_arg.SetFold (fun opts b -> install_flag := b; install_force := b; opts), (**) "Force overwriting of files during installation; implies --install"; "--version", Lm_arg.Unit (fun () -> Lm_printf.printf "%s\n\nDefault library directory : %s@." Omake_magic.version_message Omake_magic.lib_dir; if Omake_state.lib_dir_reason <> "" then Lm_printf.printf "Using library directory : %s\n\t(as specified by the %s)@." (**) Omake_state.lib_dir Omake_state.lib_dir_reason; exit 0), (**) "Print the version string and exit"]; "Shell flags", (**) ["--shell", Lm_arg.Set shell_flag, (**) "Run the OMake shell: osh"; "-i", Lm_arg.SetFold (fun opts b -> Lm_readline.set_interactive b; opts), (**) "Treat the session as interactive"; "-c", Lm_arg.String (fun s -> command_string := Some s), (**) "Evaluate the commands from the string"]; "Debugging flags", (**) ["-print-ast", Lm_arg.Set Omake_eval.print_ast, (**) "Print the AST after parsing"; "-print-ir", Lm_arg.Set Omake_eval.print_ir, (**) "Print the IR"; "-print-loc", Lm_arg.Set Omake_ast_print.print_location, (**) "Also print locations"; "-print-rules", Lm_arg.Set Omake_eval.print_rules, (**) "Print the rules after evaluation"; "-print-files", Lm_arg.Set Omake_eval.print_files, (**) "Print the files as they are read"; "-debug-deps", Lm_arg.Set Omake_build.debug_deps, (**) "Display dependency information as scanned"; "-debug-ast-lex", Lm_arg.Set Omake_ast_lex.debug_lex, (**) "Print tokens as they are scanned"; "-debug-cache", Lm_arg.Set Omake_cache.debug_cache, (**) "Display cache debugging information"; "-debug-exec", Lm_arg.Set Omake_exec_util.debug_exec, (**) "Display execution debugging information"; "-debug-rule", Lm_arg.Set Omake_build.debug_rule, (**) "Display debugging information about rule execution"; "-debug-build", Lm_arg.Set Omake_build.debug_build, (**) "Display debugging information during the build"; "-debug-scanner", Lm_arg.Set Omake_env.debug_scanner, (**) "Display debugging information for scanner selection"; "-debug-implicit", Lm_arg.Set Omake_env.debug_implicit, (**) "Display debugging information for implicit rule selection"; "-debug-pos", Lm_arg.Set Lm_position.debug_pos, (**) "Print source position information on error"; "-trace-pos", Lm_arg.Set Lm_position.trace_pos, (**) "Trace the program execution"; "-debug-remote", Lm_arg.Set Omake_exec_remote.debug_remote, (**) "Debug remote execution"; "-debug-active-rules", Lm_arg.Set Omake_rule.debug_active_rules, (**) "Debug active rules"; "-debug-shell", Lm_arg.Set Omake_shell_type.debug_shell, (**) "Debug shell operations"; "-debug-eval", Lm_arg.Set Omake_eval.debug_eval, (**) "Debug the evaluator"; "-debug-lex", Lm_arg.Set Lm_lexer.debug_lex, (**) "Debug the lexer"; "-debug-lexgen", Lm_arg.Set Lm_lexer.debug_lexgen, (**) "Debug the lexer generator"; "-debug-parse", Lm_arg.Set Lm_parser.debug_parse, (**) "Debug the parser"; "-debug-parsegen", Lm_arg.Set Lm_parser.debug_parsegen, (**) "Debug the parser generator"; "-debug-parsing", Lm_arg.Set Omake_builtin_io_fun.debug_parsing, (**) "Debug OMake parsing operations"; "-debug-notify", Lm_arg.Set Lm_notify.debug_notify, (**) "Debug the FAM (-p filesystem watch) operations"; "-debug-db", Lm_arg.Set Omake_env.debug_db, (**) "Debug the file database"; "-debug-hash", Lm_arg.Set debug_hash, (**) "Show Lm_hash statistics"; "-debug-thread", Lm_arg.Set Lm_thread_pool.debug_thread, (**) "Show thread operations"; "-allow-exceptions", Lm_arg.SetFold set_allow_exceptions_opt, (**) "Do not catch top-level exceptions (for use with OCAMLRUNPARAM=b)"; "-extended-rusage", Lm_arg.Set extended_rusage, (**) "Print more about resource usage"; "-instrument", Lm_arg.Set Lm_instrument.enabled, (**) "Do instrument functions"; ]; "Internal flags", (**) ["-server", Lm_arg.String (fun s -> server_flag := Some s), (**) "Run as a remote server";]]) (* * Main program. *) let main (options : Omake_options.t) = begin Sys.catch_break true ; (if Sys.os_type <> "Win32" then Sys.set_signal Sys.sigpipe Signal_ignore ); let path = Omake_main_util.chroot () in Omake_build.build options (if options.cd_root then "." else path) (match !targets with | [] -> [".DEFAULT"] | l -> List.rev l); if !debug_hash then Omake_main_util.print_hash_stats (); if !extended_rusage then ( let r = Unix.times() in let open Unix in Lm_printf.eprintf "Resources used by main process: \ user %.2fseconds, system %.2fseconds\n" r.tms_utime r.tms_stime; Lm_printf.eprintf "Resources used incl. sub processes: \ user %.2fseconds, system %.2fseconds\n" r.tms_cutime r.tms_cstime; ); if !Lm_instrument.enabled then Lm_instrument.report() end let _ = let add_unknown options s = begin ( match Lm_string_util.bi_split '=' s with | (v,x) -> Omake_build_util.add_command_def v x | exception Not_found -> targets := s :: !targets); options, !shell_flag end in let exe = Lm_filename_util.root (Filename.basename (Sys.argv.(0))) in let () = if exe = "osh" then shell_flag := true in (* Parse all the options *) let options = Omake_options.default_options in let options = try let s = Sys.getenv "OMAKEFLAGS" in let argv = Array.of_list (Sys.argv.(0) :: Lm_string_util.tokens_std s) in Lm_arg.fold_argv argv spec options add_unknown header with | Not_found | Lm_arg.UsageError -> options in let options = try Lm_arg.fold spec options add_unknown header with | Lm_arg.UsageError -> exit 0 | Lm_arg.BogusArg s -> Lm_arg.usage spec header; Lm_printf.eprintf "@\n@[*** omake fatal error:@ %s@]@." s; exit 3 in Lm_thread_core.debug_mutex := !Lm_thread_pool.debug_thread; Lm_thread.debug_lock := !Lm_thread_pool.debug_thread; (* Run it *) match !server_flag with | Some cwd -> Omake_main_util.main_remote cwd options !targets | None -> if !shell_flag then Omake_shell.shell options !command_string (List.rev !targets) else if !install_flag then if !install_subdirs then Omake_install.install_subdirs !install_force else Omake_install.install_current !install_force else if Omake_options.opt_allow_exceptions options then main options else Omake_exn_print.catch main options (* Main entry point *) omake-0.10.3/src/main/omake_shell.ml0000644000175000017500000002662113177364665015674 0ustar gerdgerd include Omake_pos.Make (struct let name = "Omake_shell" end) (* * Empty environment. *) let node_empty = Omake_node.Node.create_phony_global "interactive shell input" (* * The parser. *) let parse_string venv s = let ast = Omake_ast_lex.parse_string s in let _ = if Lm_debug.debug Omake_eval.print_ast then Lm_printf.eprintf "@[AST:@ %a@]@." Omake_ast_print.pp_print_prog ast in let senv = Omake_ir_ast.penv_of_vars (Omake_eval.eval_open_file venv) venv node_empty (Omake_env.venv_include_scope venv IncludePervasives) in let _, ir = Omake_ir_ast.compile_exp_list senv ast in Omake_eval.postprocess_ir venv ir let parse_ir state venv senv prompt = let ast = Omake_ast_lex.parse_shell state prompt in let _ = if Lm_debug.debug Omake_eval.print_ast then Lm_printf.eprintf "@[AST:@ %a@]@." Omake_ast_print.pp_print_prog ast in let senv, ir = Omake_ir_ast.compile_exp_list senv ast in let e = (* We are interested in not hiding top-level values. *) match ir.ir_exp with SequenceExp (_, [e]) -> e | e -> e in let ir = { ir with ir_exp = e } in senv, Omake_eval.postprocess_ir venv ir (* * The result printer. *) let print_result result = match result with | Omake_value_type.ValNone | ValQuote [] | ValSequence [] | ValArray [] | ValString "" | ValWhite _ | ValClass _ | ValOther (ValExitCode 0) -> () | ValInt _ | ValFloat _ | ValSequence _ | ValArray _ | ValData _ | ValQuote _ | ValQuoteString _ | ValString _ | ValNode _ | ValDir _ | ValMaybeApply _ | ValVar _ | ValObject _ | ValMap _ | ValChannel _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValStringExp _ | ValBody _ | ValRules _ | ValOther _ | ValCases _ | ValDelayed _ -> Lm_printf.printf "- : %a@." Omake_value_print.pp_print_value result (* * Load a history file when the variable changes. *) let load_history_file = let existing_file = ref None in let load venv pos = try let v = Omake_env.venv_find_var_exn venv Omake_var.history_file_var in match v with ValNone -> () | _ -> let node = Omake_value.file_of_value venv pos v in let filename = Omake_node.Node.fullname node in if !existing_file <> Some filename then begin Lm_readline.load filename; existing_file := Some filename end with Not_found -> () | _ -> Lm_printf.eprintf "*** osh: error loading history-file@." in load (* * Set the history length when the variable changes. *) let set_history_length = let existing_length = ref 0 in let set venv pos = try let v = Omake_env.venv_find_var_exn venv Omake_var.history_length_var in let i = Omake_value.int_of_value venv pos v in if !existing_length <> i then begin Lm_readline.set_length i; existing_length := i end with Not_found -> () | _ -> Lm_printf.eprintf "*** omake: error setting history-length@." in set (* * Tell readline about the current directory. *) let set_current_directory venv = let cwd = Omake_env.venv_dir venv in Lm_readline.set_directory (Omake_node.Dir.absname cwd) (* * Save the history when exiting. *) let exit code = Lm_readline.save (); Pervasives.exit code (* * Abort if asked. *) let maybe_exit_on_exception pos venv = let abort = try Omake_value.bool_of_value venv pos (Omake_env.venv_find_var_exn venv Omake_var.exit_on_uncaught_exception_var) with Not_found -> false in if abort then exit Omake_state.exn_error_code (* * The shell main loop. *) let rec main state senv venv result = (* Prompt for input *) let loc = Omake_ast_lex.current_location state in let pos = string_pos "shell" (loc_exp_pos loc) in let () = (* Cleanup any jobs that have finished *) Omake_shell_job.cleanup venv; (* Save any static values *) Omake_env.venv_save_static_values venv; (* Load from the history file if the variable has changed *) load_history_file venv pos; (* Set the length of the history file *) set_history_length venv pos; (* Set the current directory *) set_current_directory venv; (* Install the callback for command completion *) Omake_shell_completion.set_completion_functions venv pos loc in let prompt = try let prompt = Omake_value_type.ValStringExp (Omake_env.venv_get_env venv, ApplyString (loc, VarVirtual (loc, Omake_symbol.prompt_sym), [], [])) in Omake_value.string_of_value venv pos prompt with Omake_value_type.OmakeException _ | Omake_value_type.UncaughtException _ | Omake_value_type.RaiseException _ | Unix.Unix_error _ | Sys_error _ | Failure _ | Not_found | Omake_value_type.Return _ -> "% " in (* Evaluate it *) let senv, venv, result = try let senv, ir = parse_ir state venv senv prompt in let venv, result = Omake_eval.eval_exp venv result ir.ir_exp in senv, venv, result with End_of_file -> if Omake_env.venv_defined venv Omake_var.ignoreeof_var then begin Lm_printf.eprintf "^D@.Use \"exit\" leave osh.@."; senv, venv, result end else exit 0 | Unix.Unix_error _ | Invalid_argument _ | Sys_error _ | Failure _ | Not_found as exn -> Lm_printf.eprintf "%a@." Omake_exn_print.pp_print_exn (Omake_value_type.UncaughtException (pos, exn)); maybe_exit_on_exception pos venv; senv, venv, ValNone | Omake_value_type.ExitException (_, code) -> exit code | exn -> Lm_printf.eprintf "%a@." Omake_exn_print.pp_print_exn exn; maybe_exit_on_exception pos venv; senv, venv, ValNone in print_result result; main state senv venv result (* * Run an interactive shell. *) let shell_interactive venv = (* Interactive mode *) Omake_shell_sys.set_interactive true; let state = Omake_ast_lex.create_shell () in let () = if Sys.os_type <> "Win32" then let _ = Sys.signal Sys.sigttou Sys.Signal_ignore in let _ = Sys.signal Sys.sigint Sys.Signal_ignore in let _ = Sys.signal Sys.sigquit Sys.Signal_ignore in let _ = Sys.signal Sys.sigtstp Sys.Signal_ignore in () in (* Set up the environment *) let venv = Omake_env.venv_add_var venv Omake_var.argv_var (ValString Sys.argv.(0)) in let venv = Omake_env.venv_add_var venv Omake_var.star_var ValNone in let venv = Omake_env.venv_add_var venv Omake_var.file_var (ValNode node_empty) in let senv = Omake_ir_ast.penv_of_vars (Omake_eval.eval_open_file venv) venv node_empty (Omake_env.venv_include_scope venv IncludeAll) in main state senv venv ValNone (* * Non-interactive shell to run some files. *) let shell_script venv scriptname args = (* Non-interactive mode *) Omake_shell_sys.set_interactive false; let loc = Lm_location.bogus_loc scriptname in let pos = string_pos "shell_targets" (loc_exp_pos loc) in let node = Omake_env.venv_intern venv PhonyProhibited scriptname in (* Add the command line to the environment *) let argv = scriptname :: args in let argv_val = Omake_value_type.ValArray (List.map (fun s -> Omake_value_type.ValString s) argv) in let venv = Omake_env.venv_add_var venv Omake_var.argv_var argv_val in let star_val = Omake_value_type.ValArray (List.map (fun s -> Omake_value_type.ValString s) args) in let venv = Omake_env.venv_add_var venv Omake_var.star_var star_val in let venv, _ = List.fold_left (fun (venv, i) s -> let v = Omake_var.create_numeric_var i in let venv = Omake_env.venv_add_var venv v (ValString s) in venv, succ i) (venv, 0) argv in (* Evaluate the file *) if !Omake_shell_type.debug_shell then Lm_printf.eprintf "@[<3>shell_script (pid=%i): running script@ %a@]@." (**) (Unix.getpid()) Omake_node.pp_print_node node; try ignore (Omake_eval.eval_include_file venv IncludeAll pos loc node) with End_of_file -> if !Omake_shell_type.debug_shell then Lm_printf.eprintf "@[<3>shell_script (pid=%i): script@ %a:@ got EOF, exiting@]@." (**) (Unix.getpid()) Omake_node.pp_print_node node; exit 0 | Omake_value_type.Return _ | Omake_value_type.OmakeException _ | Omake_value_type.UncaughtException _ | Omake_value_type.RaiseException _ as exn -> if !Omake_shell_type.debug_shell then Lm_printf.eprintf "@[<3>shell_script (pid=%i): script@ %a:@ got exception, exiting@]@." (**) (Unix.getpid()) Omake_node.pp_print_node node; Lm_printf.eprintf "%a@." Omake_exn_print.pp_print_exn exn; exit Omake_state.exn_error_code | Omake_value_type.ExitException (_, code) -> if !Omake_shell_type.debug_shell then Lm_printf.eprintf "@[<3>shell_script (pid=%i): script@ %a:@ got exit exception (code = %i), exiting@]@." (**) (Unix.getpid()) Omake_node.pp_print_node node code; exit code | exn -> Lm_printf.eprintf "%a@." Omake_exn_print.pp_print_exn (Omake_value_type.UncaughtException (pos, exn)); maybe_exit_on_exception pos venv (* * Evaluate a string. *) let shell_string venv s = (* Non-interactive mode *) Omake_shell_sys.set_interactive false; (* Evaluate the string *) try ignore (Omake_eval.eval_exp venv ValNone (parse_string venv s).ir_exp) with End_of_file -> Lm_printf.eprintf "Empty command: %s@." s; exit 1 | Omake_value_type.Return _ | Omake_value_type.OmakeException _ | Omake_value_type.UncaughtException _ | Omake_value_type.RaiseException _ as exn -> Lm_printf.eprintf "%a@." Omake_exn_print.pp_print_exn exn; exit Omake_state.exn_error_code | Omake_value_type.ExitException (_, code) -> exit code | exn -> Lm_printf.eprintf "%a@." Omake_exn_print.pp_print_exn exn; maybe_exit_on_exception (string_exp_pos "shell_string") venv (* * Get the initial environment. *) let create_venv options targets = (* Non-interactive mode *) Omake_shell_sys.set_interactive false; (* Move to ~/.omake *) let cwd = Omake_node.Dir.cwd () in let () = Unix.chdir (Omake_state.omake_dir ()); Omake_node.Dir.reset_cwd () in (* Now start creating *) let exec = Omake_exec.Exec.create cwd options in let cache = Omake_cache.create () in let venv = Omake_env.create options "." exec cache in let venv = Omake_env.venv_chdir_tmp venv cwd in let venv = Omake_builtin.venv_add_command_defs venv in let venv = Omake_env.venv_add_var venv Omake_var.targets_var (ValString (String.concat " " targets)) in let venv = Omake_builtin.venv_add_builtins venv in let venv = Omake_builtin.venv_include_rc_file venv Omake_state.omakeinit_file in let venv = Omake_builtin.venv_add_pervasives venv in let venv = Omake_builtin.venv_add_command_defs venv in let venv = Omake_builtin.venv_include_rc_file venv Omake_state.oshrc_file in venv (* * Run the shell. *) let shell options command targets = let options = Omake_options.set_osh_opt options in let venv = try create_venv options targets with exn when not (Omake_options.opt_allow_exceptions options) -> Lm_printf.eprintf "%a@." Omake_exn_print.pp_print_exn exn; exit Omake_state.exn_error_code in match command with Some command -> shell_string venv command | None -> match targets with [] -> shell_interactive venv | filename :: args -> shell_script venv filename args omake-0.10.3/src/main/omake_main.mli0000644000175000017500000000000013177364666015642 0ustar gerdgerdomake-0.10.3/src/main/omake_shell.mli0000644000175000017500000000013413177364666016035 0ustar gerdgerd(* Shell toploop. *) val shell : Omake_options.t -> string option -> string list -> unit omake-0.10.3/src/builtin/0000755000175000017500000000000013177364666013573 5ustar gerdgerdomake-0.10.3/src/builtin/OMakefile0000644000175000017500000000122113177364665015345 0ustar gerdgerdOCAMLINCLUDES[] += ../libmojave ../front ../magic ../ir ../env ../exec ../shell ../eval ../build FILES[] = omake_printf omake_builtin_util omake_builtin_base omake_builtin_arith omake_builtin_file omake_builtin_fun omake_builtin_io omake_builtin_io_fun omake_builtin_sys omake_builtin_target omake_builtin_shell omake_builtin_rule omake_builtin_object omake_builtin_test omake_builtin_ocamldep OCAML_LIB_FLAGS = -linkall MakeOCamlLibrary(builtin, $(FILES)) clean: $(CLEAN) # # Generate a Makefile # MakeOCamlDepend($(FILES), magic.cma) MakeMakefile() omake-0.10.3/src/builtin/omake_builtin_io_fun.ml0000644000175000017500000021024713177364665020313 0ustar gerdgerd(* * \begin{doc} * \section{Higher-level IO functions} * * \subsection{Regular expressions} * \index{regular expressions} * * Many of the higher-level functions use regular expressions. * Regular expressions are defined by strings with syntax nearly identical * to \Cmd{awk}{1}. * * Strings may contain the following character constants. * * \begin{itemize} * \item \verb+\\+ : a literal backslash. * \item \verb+\a+ : the alert character \verb+^G+. * \item \verb+\b+ : the backspace character \verb+^H+. * \item \verb+\f+ : the formfeed character \verb+^L+. * \item \verb+\n+ : the newline character \verb+^J+. * \item \verb+\r+ : the carriage return character \verb+^M+. * \item \verb+\t+ : the tab character \verb+^I+. * \item \verb+\v+ : the vertical tab character. * \item \verb+\xhh...+ : the character represented by the string * of hexadecimal digits \verb+h+. All valid hexadecimal digits * following the sequence are considered to be part of the sequence. * \item \verb+\ddd+ : the character represented by 1, 2, or 3 octal * digits. * \end{itemize} * * Regular expressions are defined using the special characters \verb+.\^$[(){}*?++. * * \begin{itemize} * \item \verb+c+ : matches the literal character \verb+c+ if \verb+c+ is not * a special character. * \item \verb+\c+ : matches the literal character \verb+c+, even if \verb+c+ * is a special character. * \item \verb+.+ : matches any character, including newline. * \item \verb+^+ : matches the beginning of a line. * \item \verb+$+ : matches the end of line. * \item \verb+[abc...]+ : matches any of the characters \verb+abc...+ * \item \verb+[^abc...]+ : matches any character except \verb+abc...+ * \item \verb+r1|r2+ : matches either \verb+r1+ or \verb+r2+. * \item \verb+r1r2+ : matches \verb+r1+ and then \verb+r2+. * \item \verb+r++ : matches one or more occurrences of \verb+r+. * \item \verb+r*+ : matches zero or more occurrences of \verb+r+. * \item \verb+r?+ : matches zero or one occurrence of \verb+r+. * \item \verb+(r)+ : parentheses are used for grouping; matches \verb+r+. * \item \verb+\(r\)+ : also defines grouping, but the expression matched * within the parentheses is available to the output processor * through one of the variables \verb+$1+, \verb+$2+, ... * \item \verb+r{n}+ : matches exactly \verb+n+ occurrences of \verb+r+. * \item \verb+r{n,}+ : matches \verb+n+ or more occurrences of \verb+r+. * \item \verb+r{n,m}+ : matches at least \verb+n+ occurrences of \verb+r+, * and no more than \verb+m+ occurrences. * \item \verb+\y+: matches the empty string at either the beginning or * end of a word. * \item \verb+\B+: matches the empty string within a word. * \item \verb+\<+: matches the empty string at the beginning of a word. * \item \verb+\>+: matches the empty string at the end of a word. * \item \verb+\w+: matches any character in a word. * \item \verb+\W+: matches any character that does not occur within a word. * \item \verb+\`+: matches the empty string at the beginning of a file. * \item \verb+\'+: matches the empty string at the end of a file. * \end{itemize} * * Character classes can be used to specify character sequences * abstractly. Some of these sequences can change depending on your LOCALE. * * \begin{itemize} * \item \verb+[[:alnum:]]+ Alphanumeric characters. * \item \verb+[[:alpha:]]+ Alphabetic characters. * \item \verb+[[:lower:]]+ Lowercase alphabetic characters. * \item \verb+[[:upper:]]+ Uppercase alphabetic characters. * \item \verb+[[:cntrl:]]+ Control characters. * \item \verb+[[:digit:]]+ Numeric characters. * \item \verb+[[:xdigit:]]+ Numeric and hexadecimal characters. * \item \verb+[[:graph:]]+ Characters that are printable and visible. * \item \verb+[[:print:]]+ Characters that are printable, whether they are visible or not. * \item \verb+[[:punct:]]+ Punctuation characters. * \item \verb+[[:blank:]]+ Space or tab characters. * \item \verb+[[:space:]]+ Whitespace characters. * \end{itemize} * \end{doc} * *) include Omake_pos.Make (struct let name = "Omake_builtin_io_fun" end) let debug_parsing = Lm_debug.create_debug (**) { debug_name = "parsing"; debug_description = "Debug parsing operations"; debug_value = false } (* * Concatenate files into a string. * * \begin{doc} * \fun{cat} * * \begin{verbatim} * cat(files) : Sequence * files : File or InChannel Sequence * \end{verbatim} * * The \verb+cat+ function concatenates the output from multiple files * and returns it as a string. * \end{doc} *) let cat venv pos loc args = let pos = string_pos "cat" pos in match args with [arg] -> let names = Omake_value.values_of_value venv pos arg in let buf = Buffer.create 1024 in List.iter (fun name -> try let inp, close_flag = Omake_value.in_channel_of_any_value venv pos name in let inx = Omake_env.venv_find_channel venv pos inp in let rec copy () = let c = Lm_channel.input_char inx in Buffer.add_char buf c; copy () in let () = try copy () with End_of_file -> () in if close_flag then Omake_env.venv_close_channel venv pos inp with Sys_error _ -> let print_error buf = Format.fprintf buf "unable to open file: %a" Omake_value_print.pp_print_value name in raise (Omake_value_type.OmakeException (loc_pos loc pos, LazyError print_error))) names; Omake_value_type.ValString (Buffer.contents buf) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Grep takes some flags. * * \begin{doc} * \fun{grep} * * \begin{verbatim} * grep(pattern) : String # input from stdin, default options * pattern : String * grep(pattern, files) : String # default options * pattern : String * files : File Sequence * grep(options, pattern, files) : String * options : String * pattern : String * files : File Sequence * \end{verbatim} * * The \verb+grep+ function searches for occurrences of a regular * expression \verb+pattern+ in a set of files, and prints lines that match. * This is like a highly-simplified version of \Cmd{grep}{1}. * * The options are: * \begin{description} * \item[q] If specified, the output from \verb+grep+ is not displayed. * \item[h] If specified, output lines will not include the filename (default, when only one input * file is given). * \item[n] If specified, output lines include the filename (default, when more than one input file * is given). * \item[v] If specified, search for lines without a match instead of lines with a match, * \end{description} * * The \verb+pattern+ is a regular expression. * * If successful (\verb+grep+ found a match), the function returns \verb+true+. * Otherwise, it returns \verb+false+. * \end{doc} *) type grep_flag = GrepQuiet | GrepPrint | GrepNoPrint | GrepNoMatch let grep_flags pos loc s = let len = String.length s in let rec collect flags i = if i = len then flags else let flag = match s.[i] with 'q' -> GrepQuiet | 'n' -> GrepPrint | 'v' -> GrepNoMatch | 'h' -> GrepNoPrint | c -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("illegal grep option", String.make 1 c))) in collect (flag::flags) (succ i) in collect [] 0 let grep venv pos loc args = let pos = string_pos "grep" pos in let outx = Omake_value.channel_of_var venv pos loc Omake_var.stdout_var in let flags, pattern, files = match args with [pattern] -> Omake_value_type.ValNone, pattern, Omake_value_type.ValNone | [pattern; files] -> ValNone, pattern, files | [flags; pattern; files] -> flags, pattern, files | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (1, 3), List.length args))) in let flags = grep_flags pos loc (Omake_value.string_of_value venv pos flags) in let pattern = Omake_value.string_of_value venv pos pattern in let pattern = try Omake_lexer.lexer_of_string pattern with Failure err -> let msg = Lm_printf.sprintf "Mailformed regular expression '%s'" pattern in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError (msg, err))) in let files = Omake_value.values_of_value venv pos files in let flags, files = match files with [] -> flags, [Omake_env.venv_find_var venv pos loc Omake_var.stdin_var] | [_] -> flags, files | _::_::_ -> (if List.mem GrepNoPrint flags then flags else GrepPrint :: flags), files in let verbose = not (List.mem GrepQuiet flags) in let print = List.mem GrepPrint flags in let matches = not (List.mem GrepNoMatch flags) in (* Grep against a single line *) let grep_line file found line = let b = (Omake_lexer.lexer_matches pattern line == matches) in if b && verbose then begin if print then begin Lm_channel.output_string outx file; Lm_channel.output_char outx ':' end; Lm_channel.output_string outx line; Lm_channel.output_char outx '\n' end; found || b in (* Open the file *) let grep_file found s = let filename = Omake_value.string_of_value venv pos s in let inp, close_flag = Omake_value.in_channel_of_any_value venv pos s in let inx = Omake_env.venv_find_channel venv pos inp in let rec search found = let text = try Some (Lm_channel.input_line inx) with End_of_file -> None in match text with Some line' -> search (grep_line filename found line') | None -> found in let found = search found in if close_flag then Omake_env.venv_close_channel venv pos inp; found in let b = List.fold_left grep_file false files in Lm_channel.flush outx; Omake_builtin_util.val_of_bool b let builtin_grep venv pos loc args = let pos = string_pos "builtin-grep" pos in let args = match args with [arg] -> Omake_value.values_of_value venv pos arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in (* Eat options *) let flags, pattern, files = let rec collect flags args = match args with arg :: args -> (match Omake_value.string_of_value venv pos arg with "-q" -> collect ("q" ^ flags) args | "-n" -> collect ("n" ^ flags) args | "-v" -> collect ("v" ^ flags) args | "-h" -> collect ("h" ^ flags) args | pattern -> flags, pattern, args) | [] -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError "no pattern specified")) in collect "" args in grep venv pos loc [ValData flags; ValData pattern; ValArray files] (* * \begin{doc} * \fun{scan} * * \begin{verbatim} * scan(input-files) * case string1 * body1 * case string2 * body2 * ... * default * bodyd * \end{verbatim} * * The \verb+scan+ function provides input processing in command-line form. * The function takes file/filename arguments. If called with no * arguments, the input is taken from \verb+stdin+. If arguments are provided, * each specifies an \verb+InChannel+, or the name of a file for input. * Output is always to \verb+stdout+. * * The \verb+scan+ function operates by reading the input one line at a time, * and processing it according to the following algorithm. * * For each line, * the record is first split into fields, and * the fields are bound to the variables \verb+$1, $2, ...+. The variable * \verb+$0+ is defined to be the entire line, and \verb+$*+ is an array * of all the field values. The \verb+$(NF)+ variable is defined to be the number * of fields. * * Next, a case expression is selected. If \verb+string_i+ matches the token \verb+$1+, * then \verb+body_i+ is evaluated. If the body ends in an \verb+export+, the state * is passed to the next clause. Otherwise the value is discarded. * * For example, here is an \verb+scan+ function that acts as a simple command processor. * * \begin{verbatim} * calc() = * i = 0 * scan(script.in) * case print * println($i) * case inc * i = $(add $i, 1) * export * case dec * i = $(sub $i, 1) * export * case addconst * i = $(add $i, $2) * export * default * eprintln($"Unknown command: $1") * \end{verbatim} * * The \verb+scan+ function also supports several options. * * \begin{verbatim} * scan(options, files) * ... * \end{verbatim} * * \begin{description} * \item[A] Parse each line as an argument list, where arguments * may be quoted. For example, the following line has three words, * ``\verb+ls+'', ``\verb+-l+'', ``\verb+Program Files+''. * * \begin{verbatim} * ls -l "Program Files" * \end{verbatim} * \item[O] Parse each line using white space as the separator, using the * usual \OMake{} algorithm for string parsing. This is the default. * \item[x] Once each line is split, reduce each word using the * hex representation. This is the usual hex representation used * in URL specifiers, so the string ``Program Files'' may be * alternately represented in the form Program%20Files or * Program+Files. * \end{description} * * Note, if you want to redirect the output to a file, the easiest way is to * redefine the \verb+stdout+ variable. The \verb+stdout+ variable is scoped the * same way as other variables, so this definition does not affect the meaning of * \verb+stdout+ outside the \verb+calc+ function. * * \begin{verbatim} * calc() = * stdout = $(fopen script.out, w) * scan(script.in) * ... * close($(stdout)) * \end{verbatim} * \end{doc} *) (* * Scanner options. *) type parse_option = ParseArgs | ParseWords type rewrite_option = RewriteHex | RewriteNone let scan_options _ pos loc options s = let len = String.length s in let rec collect ((poption, roption) as options) i = if i = len then options else let options = match s.[i] with 'A' -> ParseArgs, roption | 'O' -> ParseWords, roption | 'x' -> poption, RewriteHex | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("illegal option", s))) in collect options (succ i) in collect options 0 let scan_options venv pos loc options = List.fold_left (scan_options venv pos loc) (ParseWords, RewriteNone) (Omake_value.strings_of_value venv pos options) (* * The arguments. *) let scan_args venv pos loc (args : Omake_value_type.t list) = let pos = string_pos "scan_args" pos in let cases, options, files = match args with | [ValCases cases] -> cases, Omake_value_type.ValNone, Omake_env.venv_find_var venv pos loc Omake_var.stdin_var | [ValCases cases; files] -> cases, ValNone, files | [ValCases cases; options; files] -> cases, options, files | (ValBody _) :: _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, SyntaxError("Unexpected body (bad indentation?)"))) | [_] | [_; _] | [_; _; _] -> raise (Omake_value_type.OmakeException (loc_pos loc pos, SyntaxError("No cases"))) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let poptions, roptions = scan_options venv pos loc options in cases, poptions, roptions, Omake_value.values_of_value venv pos files (* * Awk the value. *) let scan venv pos loc args _ = let pos = string_pos "scan" pos in let cases, token_mode, rewrite_mode, files = scan_args venv pos loc args in (* Get lexers for all the cases *) let cases, def = List.fold_left (fun (cases, def) (v, test, body, export) -> if Lm_symbol.eq v Omake_symbol.case_sym then let s = Omake_value.string_of_value venv pos test in let cases = Lm_symbol.SymbolTable.filter_add cases (Lm_symbol.add s) (fun b -> match b with Some _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("duplicate case", v))) | None -> body, export) in cases, def else if Lm_symbol.eq v Omake_symbol.default_sym then match def with Some _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError "duplicate default case")) | None -> cases, Some (body, export) else raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("unknown case", v)))) (Lm_symbol.SymbolTable.empty, None) cases in (* Split a line into words *) let collect_words_argv line = let words = match token_mode with ParseArgs -> Lm_string_util.parse_args line | ParseWords -> Omake_value.strings_of_value venv pos (ValString line) in match rewrite_mode with RewriteHex -> List.map Lm_string_util.decode_hex_name words | RewriteNone -> words in (* Select a case and run it *) let eval_case venv words = let body = match words with command :: _ -> (try Some (Lm_symbol.SymbolTable.find cases (Lm_symbol.add command)) with Not_found -> def) | [] -> def in match body with Some (body, export) -> let venv_new, _ = Omake_eval.eval_sequence_exp venv pos body in Omake_env.add_exports venv venv_new pos export | None -> venv in (* Read the file a line at a time *) let rec line_loop venv inx = let text = try Some (Lm_channel.input_line inx) with End_of_file -> None in match text with Some line -> let words = collect_words_argv line in let venv = Omake_env.venv_add_match venv line words in let venv = eval_case venv words in line_loop venv inx | None -> venv in let rec file_loop venv args = match args with arg :: args -> let inp, close_in = Omake_value.in_channel_of_any_value venv pos arg in let inx = Omake_env.venv_find_channel venv pos inp in let venv = try line_loop venv inx with exn when close_in -> Omake_env.venv_close_channel venv pos inp; raise exn in if close_in then Omake_env.venv_close_channel venv pos inp; file_loop venv args | [] -> venv in file_loop venv files, Omake_value_type.ValNone (* * \begin{doc} * \fun{awk} * * \begin{verbatim} * awk(input-files) * case pattern1: * body1 * case pattern2: * body2 * ... * default: * bodyd *\end{verbatim} * * or * * \begin{verbatim} * awk(options, input-files) * case pattern1: * body1 * case pattern2: * body2 * ... * default: * bodyd * \end{verbatim} * * The \verb+awk+ function provides input processing similar to \Cmd{awk}{1}, * but more limited. The \verb+input-files+ argument is a sequence of values, * each specifies an \verb+InChannel+, or the name of a file for input. * If called with no options and no file arguments, the input is taken from \verb+stdin+. * Output is always to \verb+stdout+. * * The variables \verb+RS+ and \verb+FS+ define record and field separators * as regular expressions. * The default value of \verb+RS+ is the regular expression \verb+\r|\n|\r\n+. * The default value of \verb+FS+ is the regular expression \verb+[ \t]++. * * The \verb+awk+ function operates by reading the input one record at a time, * and processing it according to the following algorithm. * * For each line, * the record is first split into fields using the field separator \verb+FS+, and * the fields are bound to the variables \verb+$1, $2, ...+. The variable * \verb+$0+ is defined to be the entire line, and \verb+$*+ is an array * of all the field values. The \verb+$(NF)+ variable is defined to be the number * of fields. * * Next, the cases are evaluated in order. * For each case, if the regular expression \verb+pattern_i+ matches the record \verb+$0+, * then \verb+body_i+ is evaluated. If the body ends in an \verb+export+, the state * is passed to the next clause. Otherwise the value is discarded. If the regular * expression contains \verb+\(r\)+ expression, those expression override the * fields \verb+$1, $2, ...+. * * For example, here is an \verb+awk+ function to print the text between two * delimiters \verb+\begin{}+ and \verb+\end{}+, where the \verb++ * must belong to a set passed as an argument to the \verb+filter+ function. * * \begin{verbatim} * filter(names) = * print = false * * awk(Awk.in) * case $"^\\end\{\([[:alpha:]]+\)\}" * if $(mem $1, $(names)) * print = false * export * export * default * if $(print) * println($0) * case $"^\\begin\{\([[:alpha:]]+\)\}" * print = $(mem $1, $(names)) * export * \end{verbatim} * * Note, if you want to redirect the output to a file, the easiest way is to * redefine the \verb+stdout+ variable. The \verb+stdout+ variable is scoped the * same way as other variables, so this definition does not affect the meaning of * \verb+stdout+ outside the \verb+filter+ function. * * \begin{verbatim} * filter(names) = * stdout = $(fopen file.out, w) * awk(Awk.in) * ... * close($(stdout)) * \end{verbatim} * * Options. * \begin{description} * \item[b] ``Break'' when evaluating cases. Only the first case that matches will be selected. * \end{description} * * The \hyperfun{break} can be used to abort the loop, * exiting the \verb+awk+ function immediately. * \end{doc} *) (* * Evaluate all the cases that match. *) let rec awk_eval_cases venv pos loc break line cases = match cases with (None, body, export) :: cases -> let venv_new, _ = Omake_eval.eval_sequence_exp venv pos body in let venv = Omake_env.add_exports venv venv_new pos export in if break then venv else awk_eval_cases venv pos loc break line cases | (Some lex, body, export) :: cases -> let channel = Lm_channel.of_string line in let venv, stop = match Omake_lexer.Lexer.search lex channel with Some (_, _, _, _, args) -> let venv_new = Omake_env.venv_add_match_args venv args in let venv_new, _ = Omake_eval.eval_sequence_exp venv_new pos body in let venv = Omake_env.add_exports venv venv_new pos export in venv, break | None -> venv, false in if stop then venv else awk_eval_cases venv pos loc break line cases | [] -> venv (* * The arguments. *) let awk_args venv pos loc (args : Omake_value_type.t list) = let pos = string_pos "awk_args" pos in match args with | [ValCases cases] -> cases, [Omake_env.venv_find_var venv pos loc Omake_var.stdin_var] | [ValCases cases; files] -> cases, Omake_value.values_of_value venv pos files | (ValBody _) :: _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, SyntaxError("Unexpected body (bad indentation?)"))) | [_] | [_; _] -> raise (Omake_value_type.OmakeException (loc_pos loc pos, SyntaxError("No cases"))) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (1, 2), List.length args))) let awk_option_args venv pos loc (args : Omake_value_type.t list) = let pos = string_pos "awk_args" pos in match args with | [ValCases cases] -> cases, "", [Omake_env.venv_find_var venv pos loc Omake_var.stdin_var] | [ValCases cases; files] -> cases, "", Omake_value.values_of_value venv pos files | [ValCases cases; options; files] -> cases, Omake_value.string_of_value venv pos options, Omake_value.values_of_value venv pos files | (ValBody _) :: _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, SyntaxError("Unexpected body (bad indentation?)"))) | [_] | [_; _] | [_; _; _] -> raise (Omake_value_type.OmakeException (loc_pos loc pos, SyntaxError("No cases"))) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (1, 3), List.length args))) type awk_flag = AwkBreak let awk_flags pos loc s = let len = String.length s in let rec collect flags i = if i = len then flags else let flag = match s.[i] with 'b' -> AwkBreak | c -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("illegal awk option", String.make 1 c))) in collect (flag :: flags) (succ i) in collect [] 0 (* * Awk the value. *) let awk venv pos loc args _ = let pos = string_pos "awk" pos in let cases, flags, files = awk_option_args venv pos loc args in let flags = awk_flags pos loc flags in let break = List.mem AwkBreak flags in (* Separator expressions *) let rs = try Omake_value.string_of_value venv pos (Omake_env.venv_find_var_exn venv Omake_var.rs_var) with Not_found -> "\r|\n|\r\n" in let fs = try Omake_value.string_of_value venv pos (Omake_env.venv_find_var_exn venv Omake_var.fs_var) with Not_found -> "[ \t]+" in let rs_lex = try Omake_lexer.lexer_of_string rs with Failure err -> let msg = Lm_printf.sprintf "Malformed regular expression '%s'" rs in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError (msg, err))) in let fs_lex = try Omake_lexer.lexer_of_string fs with Failure err -> let msg = Lm_printf.sprintf "Malformed regular expression '%s'" fs in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError (msg, err))) in (* Get lexers for all the cases *) let cases = List.map (fun (v, test, body, export) -> if Lm_symbol.eq v Omake_symbol.case_sym then let s = Omake_value.string_of_value venv pos test in let _, lex = try Omake_lexer.Lexer.add_clause Omake_lexer.Lexer.empty v s with Failure err -> let msg = Lm_printf.sprintf "Malformed regular expression '%s'" s in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError (msg, err))) in Some lex, body, export else if Lm_symbol.eq v Omake_symbol.default_sym then None, body, export else raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("unknown case", v)))) cases in (* Split a line into words *) let collect_words line = let channel = Lm_channel.of_string line in let rec collect words = match Omake_lexer.Lexer.searchto fs_lex channel with Omake_lexer.Lexer.LexEOF -> List.rev words | Omake_lexer.Lexer.LexSkipped (_, skipped) | Omake_lexer.Lexer.LexMatched (_, _, skipped, _, _) -> collect (skipped :: words) in collect [] in (* Read the file a line at a time *) let rec line_loop venv inx lineno = match Omake_lexer.Lexer.searchto rs_lex inx with Omake_lexer.Lexer.LexEOF -> venv | Omake_lexer.Lexer.LexSkipped (_, line) | Omake_lexer.Lexer.LexMatched (_, _, line, _, _) -> (* Split into words *) let words = collect_words line in let venv = Omake_env.venv_add_match venv line words in let venv = Omake_env.venv_add_var venv Omake_var.fnr_var (ValInt lineno) in let venv = awk_eval_cases venv pos loc break line cases in line_loop venv inx (lineno + 1) in let rec file_loop venv args = match args with arg :: args -> let inp, close_in = Omake_value.in_channel_of_any_value venv pos arg in let inx = Omake_env.venv_find_channel venv pos inp in let venv = Omake_env.venv_add_var venv Omake_var.filename_var (ValData (Lm_channel.name inx)) in let venv = try line_loop venv inx 1 with exn when close_in -> Omake_env.venv_close_channel venv pos inp; raise exn in if close_in then Omake_env.venv_close_channel venv pos inp; file_loop venv args | [] -> venv in let venv = try file_loop venv files with Omake_env.Break (_, venv) -> venv in venv, Omake_value_type.ValNone (* * \begin{doc} * \fun{fsubst} * * \begin{verbatim} * fsubst(files) * case pattern1 [options] * body1 * case pattern2 [options] * body2 * ... * default * bodyd * \end{verbatim} * * The \verb+fsubst+ function provides a \Cmd{sed}{1}-like substitution * function. Similar to \verb+awk+, if \verb+fsubst+ is called with no * arguments, the input is taken from \verb+stdin+. If arguments are provided, * each specifies an \verb+InChannel+, or the name of a file for input. * * The \verb+RS+ variable defines a regular expression that determines a record separator, * The default value of \verb+RS+ is the regular expression \verb+\r|\n|\r\n+. * * The \verb+fsubst+ function reads the file one record at a time. * * For each record, the cases are evaluated in order. Each case defines * a substitution from a substring matching the \verb+pattern+ to * replacement text defined by the body. * * Currently, there is only one option: \verb+g+. * If specified, each clause specifies a global replacement, * and all instances of the pattern define a substitution. * Otherwise, the substitution is applied only once. * * Output can be redirected by redefining the \verb+stdout+ variable. * * For example, the following program replaces all occurrences of * an expression \verb+word.+ with its capitalized form. * * \begin{verbatim} * section * stdout = $(fopen Subst.out, w) * fsubst(Subst.in) * case $"\<\([[:alnum:]]+\)\." g * value $(capitalize $1). * close($(stdout)) * \end{verbatim} * \end{doc} *) (* * Substitution options. *) let subst_global_opt = 1 let subst_options _ pos loc options s = let len = String.length s in let rec collect options i = if i = len then options else let flag = match s.[i] with 'g' -> subst_global_opt | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("illegal option", s))) in collect (options lor flag) (succ i) in collect options 0 (* * Sed function performs a substitution line-by-line. *) let rec subst_eval_case venv pos loc buf channel lex options body = match Omake_lexer.Lexer.searchto lex channel with Omake_lexer.Lexer.LexEOF -> () | Omake_lexer.Lexer.LexSkipped (_, skipped) -> Buffer.add_string buf skipped | Omake_lexer.Lexer.LexMatched (_, _, skipped, matched, args) -> let venv' = Omake_env.venv_add_match venv matched args in let _, result = Omake_eval.eval_sequence_exp venv' pos body in Buffer.add_string buf skipped; Buffer.add_string buf (Omake_value.string_of_value venv pos result); if (options land subst_global_opt) <> 0 then subst_eval_case venv pos loc buf channel lex options body else Lm_channel.LexerInput.lex_buffer channel buf let subst_eval_line venv pos loc line cases = let buffer = Buffer.create (String.length line) in List.fold_left (fun line (lex, options, body) -> let channel = Lm_channel.of_string line in Buffer.clear buffer; subst_eval_case venv pos loc buffer channel lex options body; Buffer.contents buffer) line cases let fsubst venv pos loc args _ = let pos = string_pos "fsubst" pos in let cases, files = awk_args venv pos loc args in let outp = Omake_value.prim_channel_of_var venv pos loc Omake_var.stdout_var in let outx = Omake_env.venv_find_channel venv pos outp in (* Record separator *) let rs = try Omake_value.string_of_value venv pos (Omake_env.venv_find_var_exn venv Omake_var.rs_var) with Not_found -> "\r|\n|\r\n" in let rs_lex = try Omake_lexer.lexer_of_string rs with Failure err -> let msg = Lm_printf.sprintf "Malformed regular expression '%s'" rs in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError (msg, err))) in (* Get lexers for all the cases *) let cases = List.map (fun (v, test, body, _) -> let args = Omake_value.values_of_value venv pos test in let pattern, options = match args with pattern :: options -> Omake_value.string_of_value venv pos pattern, options | [] -> "", [] in let pattern, options = if Lm_symbol.eq v Omake_symbol.case_sym then pattern, options else if Lm_symbol.eq v Omake_symbol.default_sym then ".*", [] else raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("unknown case", v))) in let options = List.fold_left (fun options arg -> subst_options venv pos loc options (Omake_value.string_of_value venv pos arg)) 0 options in let _, lex = try Omake_lexer.Lexer.add_clause Omake_lexer.Lexer.empty v pattern with Failure err -> let msg = Lm_printf.sprintf "Malformed regular expression '%s'" pattern in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError (msg, err))) in lex, options, body) cases in (* Read the file a line at a time *) let rec line_loop inx = match Omake_lexer.Lexer.searchto rs_lex inx with Omake_lexer.Lexer.LexEOF -> () | Omake_lexer.Lexer.LexSkipped (_, line) -> let line = subst_eval_line venv pos loc line cases in Lm_channel.output_string outx line | Omake_lexer.Lexer.LexMatched (_, _, line, term, _) -> let line = subst_eval_line venv pos loc line cases in Lm_channel.output_string outx line; Lm_channel.output_string outx term; line_loop inx in let rec file_loop files = match files with file :: files -> let inp, close_in = Omake_value.in_channel_of_any_value venv pos file in let inx = Omake_env.venv_find_channel venv pos inp in let () = try line_loop inx with exn when close_in -> Omake_env.venv_close_channel venv pos inp; raise exn in if close_in then Omake_env.venv_close_channel venv pos inp; file_loop files | [] -> () in let venv = try file_loop files; venv with Omake_env.Break (_, venv) -> venv in Lm_channel.flush outx; venv, Omake_value_type.ValNone (* * \begin{doc} * \fun{lex} * * \begin{verbatim} * lex(files) * case pattern1 * body1 * case pattern2 * body2 * ... * default * bodyd * \end{verbatim} * * The \verb+lex+ function provides a simple lexical-style scanner * function. The input is a sequence of files or channels. The cases * specify regular expressions. Each time the input is read, the regular * expression that matches the \emph{longest prefix} of the input is selected, * and the body is evaluated. * * If two clauses both match the same input, the \emph{last} one is selected * for execution. The \verb+default+ case matches the regular expression \verb+.+; * you probably want to place it first in the pattern list. * * If the body end with an \verb+export+ directive, * the state is passed to the next clause. * * For example, the following program collects all occurrences of alphanumeric * words in an input file. * * \begin{verbatim} * collect-words(files) = * words[] = * lex($(files)) * default * # empty * case $"[[:alnum:]]+" g * words[] += $0 * export * value $(words) * \end{verbatim} * * The \verb+default+ case, if one exists, matches single characters. Since * * It is an error if the input does not match any of the regular expressions. * * The \hyperfun{break} can be used to abort the loop. * \end{doc} *) let eof_sym = Lm_symbol.add "eof" let lex venv pos loc args _ = let pos = string_pos "lex" pos in let cases, files = awk_args venv pos loc args in (* Add a clause for EOF *) let _, lex = Omake_lexer.Lexer.add_clause Omake_lexer.Lexer.empty eof_sym "\\'" in (* Get lexers for all the cases *) let lex, cases, _ = List.fold_left (fun (lex, cases, index) (v, test, body, export) -> let args = Omake_value.values_of_value venv pos test in let pattern = match args with pattern :: _ -> Omake_value.string_of_value venv pos pattern | [] -> "" in let pattern = if Lm_symbol.eq v Omake_symbol.case_sym then pattern else if Lm_symbol.eq v Omake_symbol.default_sym then "." else raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("unknown case", v))) in let action_sym = Lm_symbol.make "action" index in let _, lex = try Omake_lexer.Lexer.add_clause lex action_sym pattern with Failure err -> let msg = Lm_printf.sprintf "Malformed regular expression '%s'" pattern in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError (msg, err))) in let cases = Lm_symbol.SymbolTable.add cases action_sym (body, export) in lex, cases, succ index) (lex, Lm_symbol.SymbolTable.empty, 0) cases in (* Process the files *) let rec input_loop venv inx = let action_sym, lexeme_loc, lexeme, args = Omake_lexer.Lexer.lex lex inx in if Lm_symbol.eq action_sym eof_sym then venv else let venv_new = Omake_env.venv_add_match venv lexeme args in let venv_new = Omake_env.venv_add_var venv_new Omake_var.parse_loc_var (ValOther (ValLocation lexeme_loc)) in let body, export = try Lm_symbol.SymbolTable.find cases action_sym with Not_found -> raise (Invalid_argument "lex") in let venv_new, _ = Omake_eval.eval_sequence_exp venv_new pos body in let venv = Omake_env.add_exports venv venv_new pos export in input_loop venv inx in let rec file_loop venv files = match files with file :: files -> let inp, close_in = Omake_value.in_channel_of_any_value venv pos file in let inx = Omake_env.venv_find_channel venv pos inp in let venv = try input_loop venv inx with (Omake_env.Break _ | Omake_value_type.Return _ ) as exn -> if close_in then Omake_env.venv_close_channel venv pos inp; raise exn | exn -> if close_in then Omake_env.venv_close_channel venv pos inp; Omake_eval.raise_uncaught_exception pos exn in if close_in then Omake_env.venv_close_channel venv pos inp; file_loop venv files | [] -> venv in let venv = try file_loop venv files with Omake_env.Break (_, venv) -> venv in venv, Omake_value_type.ValNone (* * \begin{doc} * \fun{lex-search} * * \begin{verbatim} * lex-search(files) * case pattern1 * body1 * case pattern2 * body2 * ... * default * bodyd * \end{verbatim} * * The \verb+lex-search+ function is like the \verb+lex+ function, but input that * does not match any of the regular expressions is skipped. If the clauses include * a \verb+default+ case, then the \verb+default+ matches any skipped text. * * For example, the following program collects all occurrences of alphanumeric * words in an input file, skipping any other text. * * \begin{verbatim} * collect-words($(files)) = * words[] = * lex-search($(files)) * default * eprintln(Skipped $0) * case $"[[:alnum:]]+" g * words[] += $0 * export * \end{verbatim} * * The \verb+default+ case, if one exists, matches single characters. Since * * It is an error if the input does not match any of the regular expressions. * * The \hyperfun{break} can be used to abort the loop. * \end{doc} *) let lex_search venv pos loc args _ = let pos = string_pos "lex-search" pos in let cases, files = awk_args venv pos loc args in (* Get lexers for all the cases *) let lex, cases, default, _ = List.fold_left (fun (lex, cases, default, index) (v, test, body, export) -> let args = Omake_value.values_of_value venv pos test in let pattern = match args with pattern :: _ -> Omake_value.string_of_value venv pos pattern | [] -> "" in if Lm_symbol.eq v Omake_symbol.case_sym then let action_sym = Lm_symbol.make "action" index in let _, lex = try Omake_lexer.Lexer.add_clause lex action_sym pattern with Failure err -> let msg = Lm_printf.sprintf "Malformed regular expression '%s'" pattern in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError (msg, err))) in let cases = Lm_symbol.SymbolTable.add cases action_sym (body, export) in lex, cases, default, succ index else if Lm_symbol.eq v Omake_symbol.default_sym then lex, cases, Some (body, export), index else raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("unknown case", v)))) (**) (Omake_lexer.Lexer.empty, Lm_symbol.SymbolTable.empty, None, 0) cases in (* What to do for skipped text *) let skip venv lexeme_loc lexeme = match lexeme, default with "", _ | _, None -> venv | _, Some (body, export) -> let venv_new = Omake_env.venv_add_match venv lexeme [] in let venv_new = Omake_env.venv_add_var venv_new Omake_var.parse_loc_var (ValOther (ValLocation lexeme_loc)) in let venv_new, _ = Omake_eval.eval_sequence_exp venv_new pos body in Omake_env.add_exports venv venv_new pos export in (* Process the files *) let rec input_loop venv inx = match Omake_lexer.Lexer.searchto lex inx with Omake_lexer.Lexer.LexEOF -> venv | Omake_lexer.Lexer.LexSkipped (_, lexeme) -> skip venv loc lexeme | Omake_lexer.Lexer.LexMatched (action_sym, lexeme_loc, skipped, lexeme, args) -> (* Process skipped text *) let venv = skip venv lexeme_loc skipped in (* Process the matched text *) let venv_new = Omake_env.venv_add_match venv lexeme args in let venv_new = Omake_env.venv_add_var venv_new Omake_var.parse_loc_var (ValOther (ValLocation lexeme_loc)) in let body, export = try Lm_symbol.SymbolTable.find cases action_sym with Not_found -> raise (Invalid_argument "lex") in let venv_new, _ = Omake_eval.eval_sequence_exp venv_new pos body in let venv = Omake_env.add_exports venv venv_new pos export in input_loop venv inx in (* Process each file *) let rec file_loop venv files = match files with file :: files -> let inp, close_in = Omake_value.in_channel_of_any_value venv pos file in let inx = Omake_env.venv_find_channel venv pos inp in let venv = try input_loop venv inx with (Omake_env.Break _ | Omake_value_type.Return _) as exn -> if close_in then Omake_env.venv_close_channel venv pos inp; raise exn | exn -> if close_in then Omake_env.venv_close_channel venv pos inp; Omake_eval.raise_uncaught_exception pos exn in if close_in then Omake_env.venv_close_channel venv pos inp; file_loop venv files | [] -> venv in let venv = try file_loop venv files with Omake_env.Break (_, venv) -> venv in venv, Omake_value_type.ValNone (* * \begin{doc} * \obj{Lexer} * * The \verb+Omake_lexer.Lexer+ object defines a facility for lexical analysis, similar to the * \Cmd{lex}{1} and \Cmd{flex}{1} programs. * * In \Prog{omake}, lexical analyzers can be constructed dynamically by extending * the \verb+Omake_lexer.Lexer+ class. A lexer definition consists of a set of directives specified * with method calls, and set of clauses specified as rules. * * For example, consider the following lexer definition, which is intended * for lexical analysis of simple arithmetic expressions for a desktop * calculator. * * \begin{verbatim} * lexer1. = * extends $(Omake_lexer.Lexer) * * other: . * eprintln(Illegal character: $* ) * lex() * * white: $"[[:space:]]+" * lex() * * op: $"[-+*/()]" * switch $* * case + * Token.unit($(loc), plus) * case - * Token.unit($(loc), minus) * case * * Token.unit($(loc), mul) * case / * Token.unit($(loc), div) * case $"(" * Token.unit($(loc), lparen) * case $")" * Token.unit($(loc), rparen) * * number: $"[[:digit:]]+" * Token.pair($(loc), exp, $(int $* )) * * eof: $"\'" * Token.unit($(loc), eof) * \end{verbatim} * * This program defines an object \verb+lexer1+ the extends the \verb+Omake_lexer.Lexer+ * object, which defines lexing environment. * * The remainder of the definition consists of a set of clauses, * each with a method name before the colon; a regular expression * after the colon; and in this case, a body. The body is optional, * if it is not specified, the method with the given name should * already exist in the lexer definition. * * \emph{NB} The clause that matches the \emph{longest} prefix of the input * is selected. If two clauses match the same input prefix, then the \emph{last} * one is selected. This is unlike most standard lexers, but makes more sense * for extensible grammars. * * The first clause matches any input that is not matched by the other clauses. * In this case, an error message is printed for any unknown character, and * the input is skipped. Note that this clause is selected only if no other * clause matches. * * The second clause is responsible for ignoring white space. * If whitespace is found, it is ignored, and the lexer is called * recursively. * * The third clause is responsible for the arithmetic operators. * It makes use of the \verb+Token+ object, which defines three * fields: a \verb+loc+ field that represents the source location; * a \verb+name+; and a \verb+value+. * * The lexer defines the \verb+loc+ variable to be the location * of the current lexeme in each of the method bodies, so we can use * that value to create the tokens. * * The \verb+Token.unit($(loc), name)+ * method constructs a new \verb+Token+ object with the given name, * and a default value. * * The \verb+number+ clause matches nonnegative integer constants. * The \verb+Token.pair($(loc), name, value)+ constructs a token with the * given name and value. * * \verb+Omake_lexer.Lexer+ object operate on \verb+InChannel+ objects. * The method \verb+lexer1.lex-channel(channel)+ reads the next * token from the channel argument. * * \subsection{Omake\textunderscore{}lexer.Lexer matching} * * During lexical analysis, clauses are selected by longest match. * That is, the clause that matches the longest sequence of input * characters is chosen for evaluation. If no clause matches, the * lexer raises a \verb+RuntimeException+. If more than one clause * matches the same amount of input, the first one is chosen * for evaluation. * * \subsection{Extending lexer definitions} * * Suppose we wish to augment the lexer example so that it ignores * comments. We will define comments as any text that begins with * the string \verb+(*+, ends with \verb+*)+, and comments may * be nested. * * One convenient way to do this is to define a separate lexer * just to skip comments. * * \begin{verbatim} * lex-comment. = * extends $(Omake_lexer.Lexer) * * level = 0 * * other: . * lex() * * term: $"[*][)]" * if $(not $(eq $(level), 0)) * level = $(sub $(level), 1) * lex() * * next: $"[(][*]" * level = $(add $(level), 1) * lex() * * eof: $"\'" * eprintln(Unterminated comment) * \end{verbatim} * * This lexer contains a field \verb+level+ that keeps track of the nesting * level. On encountering a \verb+(*+ string, it increments the level, * and for \verb+*)+, it decrements the level if nonzero, and continues. * * Next, we need to modify our previous lexer to skip comments. * We can do this by extending the lexer object \verb+lexer1+ * that we just created. * * \begin{verbatim} * lexer1. += * comment: $"[(][*]" * lex-comment.lex-channel($(channel)) * lex() * \end{verbatim} * * The body for the comment clause calls the \verb+lex-comment+ lexer when * a comment is encountered, and continues lexing when that lexer returns. * * \subsection{Threading the lexer object} * * Clause bodies may also end with an \verb+export+ directive. In this case * the lexer object itself is used as the returned token. If used with * the \verb+Parser+ object below, the lexer should define the \verb+loc+, \verb+name+ * and \verb+value+ fields in each \verb+export+ clause. Each time * the \verb+Parser+ calls the lexer, it calls it with the lexer returned * from the previous lex invocation. * \end{doc} *) (* * Add a lexer clause. *) let lex_rule venv pos loc (args : Omake_value_type.t list) kargs = let pos = string_pos "lex-rule" pos in match args, kargs with [_; action; _; pattern; _; ValBody (_, [], [], body, export)], [] -> let lexer = Omake_value.current_lexer venv pos in let action_name = Omake_value.string_of_value venv pos action in let action_sym = Lm_symbol.add action_name in let pattern = Omake_value.string_of_value venv pos pattern in let _, lexer = try Omake_lexer.Lexer.add_clause lexer action_sym pattern with Failure err -> let msg = Lm_printf.sprintf "Malformed regular expression '%s'" pattern in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError (msg, err))) in (* Add the method *) let action_var = Omake_ir.VarThis (loc, action_sym) in let venv = Omake_env.venv_add_var venv action_var (ValFun (Omake_env.venv_get_env venv, [], [], body, export)) in let venv = Omake_env.venv_add_var venv Omake_var.builtin_field_var (ValOther (ValLexer lexer)) in venv, Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 6, List.length args))) (* * Perform the lexing. *) let lex_engine venv pos loc args kargs = let pos = string_pos "lex" pos in match args, kargs with [arg], [] -> let lexer = Omake_value.current_lexer venv pos in let inp, close_flag = Omake_value.in_channel_of_any_value venv pos arg in let inx = Omake_env.venv_find_channel venv pos inp in let action, lexeme_loc, lexeme, args = try Omake_lexer.Lexer.lex lexer inx with Failure _ as exn -> let loc = Lm_channel.loc inx in let pos = loc_pos loc pos in if close_flag then Omake_env.venv_close_channel venv pos inp; raise (Omake_value_type.UncaughtException (pos, exn)) in let () = if close_flag then Omake_env.venv_close_channel venv pos inp in let venv = Omake_env.venv_add_match venv lexeme args in let venv = Omake_env.venv_add_var venv Omake_var.parse_loc_var (ValOther (ValLocation lexeme_loc)) in let action = Omake_env.venv_find_var venv pos loc (Omake_ir.VarThis (loc, action)) in Omake_eval.eval_apply venv pos loc action [] [] | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \obj{Parser} * * The \verb+Parser+ object provides a facility for syntactic analysis based * on context-free grammars. * * \verb+Parser+ objects are specified as a sequence of directives, * specified with method calls; and productions, specified as rules. * * For example, let's finish building the desktop calculator started * in the \verb+Lexer+ example. * * \begin{verbatim} * parser1. = * extends $(Parser) * * # * # Use the main lexer * # * lexer = $(lexer1) * * # * # Precedences, in ascending order * # * left(plus minus) * left(mul div) * right(uminus) * * # * # A program * # * start(prog) * * prog: exp eof * return $1 * * # * # Simple arithmetic expressions * # * exp: minus exp :prec: uminus * neg($2) * * exp: exp plus exp * add($1, $3) * * exp: exp minus exp * sub($1, $3) * * exp: exp mul exp * mul($1, $3) * * exp: exp div exp * div($1, $3) * * exp: lparen exp rparen * return $2 * \end{verbatim} * * Parsers are defined as extensions of the \verb+Parser+ class. * A \verb+Parser+ object must have a \verb+lexer+ field. The \verb+lexer+ * is not required to be a \verb+Lexer+ object, but it must provide * a \verb+lexer.lex()+ method that returns a token object with * \verb+name+ and \verb+value+ fields. For this example, we use the * \verb+lexer1+ object that we defined previously. * * The next step is to define precedences for the terminal symbols. * The precedences are defined with the \verb+left+, \verb+right+, * and \verb+nonassoc+ methods in order of increasing precedence. * * The grammar must have at least one start symbol, declared with * the \verb+start+ method. * * Next, the productions in the grammar are listed as rules. * The name of the production is listed before the colon, and * a sequence of variables is listed to the right of the colon. * The body is a semantic action to be evaluated when the production * is recognized as part of the input. * * In this example, these are the productions for the arithmetic * expressions recognized by the desktop calculator. The semantic * action performs the calculation. The variables \verb+$1, $2, ...+ * correspond to the values associated with each of the variables * on the right-hand-side of the production. * * \subsection{Calling the parser} * * The parser is called with the \verb+$(parser1.parse-channel start, channel)+ * or \verb+$(parser1.parse-file start, file)+ functions. The \verb+start+ * argument is the start symbol, and the \verb+channel+ or \verb+file+ * is the input to the parser. * * \subsection{Parsing control} * * The parser generator generates a pushdown automation based on LALR(1) * tables. As usual, if the grammar is ambiguous, this may generate shift/reduce * or reduce/reduce conflicts. These conflicts are printed to standard * output when the automaton is generated. * * By default, the automaton is not constructed until the parser is * first used. * * The \verb+build(debug)+ method forces the construction of the automaton. * While not required, it is wise to finish each complete parser with * a call to the \verb+build(debug)+ method. If the \verb+debug+ variable * is set, this also prints with parser table together with any conflicts. * * The \verb+loc+ variable is defined within action bodies, and represents * the input range for all tokens on the right-hand-side of the production. * * \subsection{Extending parsers} * * Parsers may also be extended by inheritance. * For example, let's extend the grammar so that it also recognizes * the \verb+<<+ and \verb+>>+ shift operations. * * First, we extend the lexer so that it recognizes these tokens. * This time, we choose to leave \verb+lexer1+ intact, instead of * using the += operator. * * \begin{verbatim} * lexer2. = * extends $(lexer1) * * lsl: $"<<" * Token.unit($(loc), lsl) * * asr: $">>" * Token.unit($(loc), asr) * \end{verbatim} * * Next, we extend the parser to handle these new operators. * We intend that the bitwise operators have lower precedence * than the other arithmetic operators. The two-argument form * of the \verb+left+ method accomplishes this. * * \begin{verbatim} * parser2. = * extends $(parser1) * * left(plus, lsl lsr asr) * * lexer = $(lexer2) * * exp: exp lsl exp * lsl($1, $3) * * exp: exp asr exp * asr($1, $3) * \end{verbatim} * * In this case, we use the new lexer \verb+lexer2+, and we add productions * for the new shift operations. * \end{doc} *) (* * Add start symbols. *) let parse_start venv pos loc args kargs = let pos = string_pos "parse-start" pos in let parse = Omake_value.current_parser venv pos in let args = match args, kargs with [arg], [] -> Omake_value.strings_of_value venv pos arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let parse = List.fold_left (fun parse s -> Omake_parser.Parser.add_start parse (Lm_symbol.add s)) parse args in (* Redefine the parser *) let venv = Omake_env.venv_add_var venv Omake_var.builtin_field_var (ValOther (ValParser parse)) in venv, Omake_value_type.ValNone (* * Precedence operations. *) let parse_prec venv pos loc args kargs assoc = let pos = string_pos "parse-prec" pos in let this = Omake_env.venv_this venv in let parse = Omake_value.current_parser venv pos in let parse, level, args = match args, kargs with [before; args], [] -> let current_prec = Lm_symbol.add (Omake_value.string_of_value venv pos before) in let level = try Omake_parser.Parser.find_prec parse current_prec with Not_found -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("no such precedence", current_prec))) in let parse, level = Omake_parser.Parser.create_prec_lt parse level assoc in parse, level, args | [args], [] -> let current_prec = Lm_symbol.add (Omake_value.string_of_value venv pos (Omake_env.venv_find_field_internal this pos Omake_symbol.current_prec_sym)) in let level = try Omake_parser.Parser.find_prec parse current_prec with Not_found -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("current precedence is not found", current_prec))) in let parse, level = Omake_parser.Parser.create_prec_gt parse level assoc in parse, level, args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (1, 2), List.length args))) in let args = Omake_value.strings_of_value venv pos args in let parse = List.fold_left (fun parse s -> Omake_parser.Parser.add_prec parse level (Lm_symbol.add s)) parse args in (* Reset the current precedence *) let venv = match args with arg :: _ -> Omake_env.venv_add_var venv Omake_var.current_prec_field_var (ValString arg) | [] -> venv in (* Redefine the parser *) let venv = Omake_env.venv_add_var venv Omake_var.builtin_field_var (ValOther (ValParser parse)) in venv, Omake_value_type.ValNone let parse_left venv pos loc args kargs = let pos = string_pos "parse-left" pos in parse_prec venv pos loc args kargs LeftAssoc let parse_right venv pos loc args kargs = let pos = string_pos "parse-right" pos in parse_prec venv pos loc args kargs RightAssoc let parse_nonassoc venv pos loc args kargs = let pos = string_pos "parse-nonassoc" pos in parse_prec venv pos loc args kargs NonAssoc (* * Build the parser. *) let parse_build venv pos loc args = let pos = string_pos "parse-build" pos in match args with [arg] -> let par = Omake_value.current_parser venv pos in let debug = Omake_value.bool_of_value venv pos arg in Omake_parser.Parser.build par debug; Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Get the precedence option. *) let prec_option venv pos _ options = Omake_env.venv_map_fold (fun _ optname optval -> let s = Omake_value.string_of_value venv pos optname in if s = ":prec:" then Some (Lm_symbol.add (Omake_value.string_of_value venv pos optval)) else raise (Omake_value_type.OmakeException (pos, StringValueError ("illegal option", optname)))) None options (* * Compute an action name that is not defined in the current object. *) let action_sym = Lm_symbol.add "action" let find_action_name venv loc = Lm_symbol.new_name action_sym (fun v -> Omake_env.venv_defined venv (Omake_ir.VarThis (loc, v))) (* * Add a parser clause. *) let parse_rule venv pos loc (args : Omake_value_type.t list) kargs = let pos = string_pos "parse-rule" pos in let action, head, rhs, options, body, export = match args, kargs with [_; action; head; rhs; ValMap options; ValBody (_, [], [], body, export)], [] -> let action = Omake_value.string_of_value venv pos action in let head = Omake_value.string_of_value venv pos head in if head = "" then (* Action name was omitted *) find_action_name venv loc, Lm_symbol.add action, rhs, options, body, export else Lm_symbol.add action, Lm_symbol.add head, rhs, options, body, export | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 6, List.length args))) in let par = Omake_value.current_parser venv pos in let rhs = List.map Lm_symbol.add (Omake_value.strings_of_value venv pos rhs) in let pre = prec_option venv pos loc options in let par = Omake_parser.Parser.add_production par action head rhs pre in (* Add the method if there is a body *) let venv = match body with _ :: _ -> let body : Omake_ir.exp list = LetVarExp (loc, Omake_ir.VarThis (loc, Omake_symbol.val_sym), [], VarDefNormal, ConstString (loc, "")) :: body in Omake_env.venv_add_var venv (Omake_ir.VarThis (loc, action)) (ValFun (Omake_env.venv_get_env venv, [], [], body, export)) | [] -> venv in (* Add back the parser *) let venv = Omake_env.venv_add_var venv Omake_var.builtin_field_var (ValOther (ValParser par)) in venv, Omake_value_type.ValNone (* * Perform the lexing. *) let parse_engine venv pos loc args = let pos = string_pos "parse-engine" pos in match args with [start] -> let dfa = Omake_value.current_parser venv pos in let start = Lm_symbol.add (Omake_value.string_of_value venv pos start) in let lexer = Omake_env.venv_find_var venv pos loc Omake_var.lexer_field_var in let lexer = Omake_eval.eval_object venv pos lexer in let parser_obj = Omake_env.venv_this venv in let lex (venv, parser_obj, lexer) = let lex = Omake_env.venv_find_field_internal lexer pos Omake_symbol.lex_sym in let venv = Omake_env.venv_with_object venv lexer in let venv, result = Omake_eval.eval_apply venv pos loc lex [] [] in let obj = Omake_eval.eval_object venv pos result in try let lex_loc = Omake_env.venv_find_field_internal_exn obj Omake_symbol.loc_sym in let lex_loc = Omake_value.loc_of_value venv pos lex_loc in let name = Omake_env.venv_find_field_internal_exn obj Omake_symbol.name_sym in let name = Lm_symbol.add (Omake_value.string_of_value venv pos name) in let value = Omake_env.venv_find_field_internal_exn obj Omake_symbol.val_sym in name, lex_loc, (venv, parser_obj, lexer), value with Not_found -> let print_error buf = Format.fprintf buf "@[The lexer returned a malformed object.\ @ @[The result of a lexer action should be an object with at least 3 fields:\ @ loc: the location of the token\ @ name: the name of the token\ @ val: the value of the token@]\ @ %a@]" Omake_value_print.pp_print_value (ValObject obj) in raise (Omake_value_type.OmakeException (pos, LazyError print_error)) in let eval (venv, parser_obj, lexer) action loc args = let pos = loc_pos loc pos in let venv = Omake_env.venv_add_match_values venv args in let action = Omake_env.venv_find_field_internal parser_obj pos action in let venv = Omake_env.venv_with_object venv parser_obj in let venv = Omake_env.venv_add_var venv Omake_var.parse_loc_var (ValOther (ValLocation loc)) in let venv, result = Omake_eval.eval_apply venv pos loc action [] [] in (venv, parser_obj, lexer), result in let _, value = try Omake_parser.Parser.parse dfa start lex eval (venv, parser_obj, lexer) with Failure _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) | Lm_parser.ParseError (loc, s) -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError s)) in value | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (************************************************************************ * External interface. *) let () = let builtin_funs = [true, "grep", grep, Omake_ir.ArityRange (1, 3); true, "builtin-grep", builtin_grep, ArityExact 1; true, "cat", cat, ArityExact 1; true, "parse-engine", parse_engine, ArityExact 1; true, "parse-build", parse_build, ArityExact 1; ] in let builtin_kfuns = [true, "lex-rule", lex_rule, Omake_ir.ArityRange (3, 4); true, "lex-engine", lex_engine, ArityExact 1; true, "parse-rule", parse_rule, ArityRange (3, 5); true, "parse-start", parse_start, ArityExact 1; true, "parse-left", parse_left, ArityExact 1; true, "parse-right", parse_right, ArityExact 1; true, "parse-nonassoc", parse_nonassoc, ArityExact 1; true, "scan", scan, ArityRange (1, 3); true, "awk", awk, ArityExact 3; true, "fsubst", fsubst, ArityExact 3; true, "lex", lex, ArityExact 3; true, "lex-search", lex_search, ArityExact 3; ] in let builtin_info = {Omake_builtin_type.builtin_empty with builtin_funs = builtin_funs; builtin_kfuns = builtin_kfuns } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_builtin_target.ml0000644000175000017500000004443613177364665020327 0ustar gerdgerd(* * Operations on targets. * * \begin{doc} * \section{Examining the dependency graph} * \end{doc} * *) include Omake_pos.Make (struct let name = "Omake_builtin_target" end) (************************************************************************ * Targets. *) (* * Find dependencies of a target. * * \begin{doc} * \threefuns{dependencies}{dependencies-all}{dependencies-proper} * * \begin{verbatim} * $(dependencies targets) : File Array * $(dependencies-all targets) : File Array * $(dependencies-proper targets) : File Array * targets : File Array * raises RuntimeException * \end{verbatim} * * The \verb+dependencies+ function returns the set of immediate dependencies of * the given targets. This function can only be used within a rule body and * all the arguments to the \verb+dependency+ function must also be dependencies of * this rule. This restriction ensures that all the dependencies are known when * this function is executed. * * The \verb+dependencies-all+ function is similar, but it expands the dependencies * recursively, returning all of the dependencies of a target, not just the immediate * ones. * * The \verb+dependencies-proper+ function returns all recursive dependencies, except * the dependencies that are leaf targets. A leaf target is a target that has no * dependencies and no build commands; a leaf target corresponds to a source file * in the current project. * * In all three functions, files that are not part of the current project are silently * discarded. All three functions will return phony and scanner targets along with the * ``real'' ones. * * One purpose of the \verb+dependencies-proper+ function is for ``clean'' targets. * For example, one way to delete all intermediate files in a build is with a rule * that uses the \verb+dependencies-proper+. Note however, that the rule requires * building the project before it can be deleted. * * \begin{verbatim} * .PHONY: clean * * APP = ... # the name of the target application * clean: $(APP) * rm -f $(dependencies-proper $(APP)) * \end{verbatim} * * Also note that the \verb+dependencies-proper+ function will return the phony and scanner * targets in addition to real one. * * For other (possibly better) alternatives, see Section~\ref{section:distclean} and * \hyperfun{filter-proper-targets}. * \end{doc} *) let dependencies venv pos loc args = let pos = string_pos "dependencies" pos in let nodes = match args with [arg] -> let args = Omake_eval.values_of_value venv pos arg in let nodes = List.map (Omake_eval.file_of_value venv pos) args in let find_deps deps node = try let env = Omake_build_util.get_env pos loc in let command = Omake_node.NodeTable.find env.env_commands node in Omake_node.NodeSet.union deps command.command_build_deps with Not_found -> raise (Omake_value_type.OmakeException (pos, StringNodeError ("file is not buildable", node))) in List.fold_left find_deps Omake_node.NodeSet.empty nodes | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in Omake_value_type.ValArray (List.map (fun v -> Omake_value_type.ValNode v) (Omake_node.NodeSet.to_list nodes)) let dependencies_all_core test venv pos loc args = let pos = string_pos "dependencies-all" pos in match args with [arg] -> let env = try Omake_build_util.get_env pos loc with Not_found -> raise (Omake_value_type.OmakeException (pos, StringError "this command can only be executed in a rule body")) in let commands = env.env_commands in let args = Omake_eval.values_of_value venv pos arg in let nodes = List.fold_left (fun nodes v -> Omake_node.NodeSet.add nodes (Omake_eval.file_of_value venv pos v)) Omake_node.NodeSet.empty args in let rec find_deps found examined unexamined = if Omake_node.NodeSet.is_empty unexamined then found else let node = Omake_node.NodeSet.choose unexamined in let unexamined = Omake_node.NodeSet.remove unexamined node in if Omake_node.NodeSet.mem examined node then find_deps found examined unexamined else let examined = Omake_node.NodeSet.add examined node in let found, deps = try let command = Omake_node.NodeTable.find commands node in let deps = command.command_build_deps in let found = if test command then Omake_node.NodeSet.add found node else found in found, deps with Not_found -> found, Omake_node.NodeSet.empty in let unexamined = Omake_node.NodeSet.union unexamined deps in find_deps found examined unexamined in let nodes = find_deps Omake_node.NodeSet.empty Omake_node.NodeSet.empty nodes in Omake_value_type.ValArray (List.map (fun v -> Omake_value_type.ValNode v) (Omake_node.NodeSet.to_list nodes)) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let dependencies_all = dependencies_all_core (fun _ -> true) let dependencies_proper = dependencies_all_core (fun command -> not (Omake_build_util.is_leaf_command command)) (* * \begin{doc} * \fun{target} * \begin{verbatim} * $(target targets) : Target Array * targets : File Sequence * raises RuntimeException * \end{verbatim} * * The \verb+target+ function returns the Target object associated with each * of the targets. See the \verb+Target+ object for more information. * \end{doc} *) let array_of_node_set nodes = Omake_value_type.ValArray (List.map (fun v -> Omake_value_type.ValNode v) (Omake_node.NodeSet.to_list nodes)) let split_command _ (values1, lines1) command = let {Omake_env. command_values = values2; command_body = lines2; command_env = venv; _ } = command in let values = List.rev_append values2 values1 in let lines = List.fold_left (fun lines line -> let v = match line with | Omake_value_type.CommandSection (_, _, e) -> let env = Omake_env.venv_get_env venv in Omake_value_type.ValBody (env, [], [], e, ExportNone) | CommandValue (_, exp, v) -> ValStringExp(exp,v) in v :: lines) lines1 lines2 in values, lines let split_commands venv (commands : Omake_build_type.command_body) = match commands with | CommandNone -> [], [] | CommandInfo info | CommandLines (info, _, _) | CommandScanner (info, _, _, _) -> List.fold_left (split_command venv) ([], []) info let target_of_command venv pos loc command = let { Omake_build_type.command_target = target; command_effects = effects; command_scanner_deps = scanner_deps; command_static_deps = static_deps; command_build_deps = build_deps; command_tee = tee; command_lines = commands; _ } = command in (* Dependency lists *) let effects = array_of_node_set effects in let scanner_deps = array_of_node_set scanner_deps in let static_deps = array_of_node_set static_deps in let build_deps = array_of_node_set build_deps in (* Command lists *) let command_values, command_lines = split_commands venv commands in (* Get the default target object *) let obj = Omake_env.venv_find_var_exn venv Omake_var.target_object_var in let obj = match obj with ValObject obj -> obj | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("object not defined", Omake_symbol.target_sym))) in (* Add the fields *) let obj = Omake_env.venv_add_field_internal obj Omake_symbol.target_sym (ValNode target) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.target_effects_sym effects in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.scanner_deps_sym scanner_deps in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.static_deps_sym static_deps in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.build_deps_sym build_deps in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.build_values_sym (ValArray command_values) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.build_commands_sym (ValArray command_lines) in (* Add the tee *) let obj = match Omake_exec_util.tee_file tee with Some name -> let node = Omake_env.venv_intern venv PhonyProhibited name in Omake_env.venv_add_field_internal obj Omake_symbol.output_file_sym (ValNode node) | None -> obj in Omake_value_type.ValObject obj let target_core optional_flag venv pos loc args = let pos = string_pos "target" pos in match args with [arg] -> let args = Omake_eval.values_of_value venv pos arg in let env = Omake_build_util.get_env pos loc in let commands = env.env_commands in let targets = List.fold_left (fun targets v -> let node = Omake_eval.file_of_value venv pos v in let target = try let command = Omake_node.NodeTable.find commands node in target_of_command venv pos loc command with Not_found -> if optional_flag then Omake_builtin_util.val_false else raise (Omake_value_type.OmakeException (pos, StringNodeError ("file is not buildable", node))) in target :: targets) [] args in Omake_value.concat_array (List.rev targets) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let target = target_core false let target_optional = target_core true (* * \begin{doc} * \fun{find-build-targets} * * \begin{verbatim} * $(find-build-targets tag) : Target Array * tag : Succeeded | Failed * \end{verbatim} * * The \verb+find-build-targets+ allow the results * of the build to be examined. The \verb+tag+ must * specifies which targets are to be returned; the comparison * is case-insensitive. * * \begin{description} * \item[Succeeded] The list of targets that were built successfully. * \item[Failed] The list of targets that could not be built. * \end{description} * * These are used mainly in conjuction with the * \verb+.BUILD_SUCCESS+ (Section~\ref{target:.BUILD_SUCCESS}) and * \verb+.BUILD_FAILURE+ (Section~\ref{target:.BUILD_FAILURE}) phony targets. * For example, adding the following to your project \verb+OMakefile+ * will print the number of targets that failed (if the build failed). * * \begin{verbatim} * .BUILD_FAILURE: * echo "Failed target count: $(length $(find-build-targets Failed))" * \end{verbatim} * \end{doc} *) let find_build_targets venv pos loc args = let pos = string_pos "find-build-targets" pos in match args with [tag] -> let tag = match String.lowercase_ascii (Omake_eval.string_of_value venv pos tag) with | "succeeded" -> Omake_build_type.CommandSucceededTag | "failed" -> CommandFailedTag | tag -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("find-build-targets: unknown option", tag))) in let env = Omake_build_util.get_env pos loc in let targets = Omake_build_util.command_fold env tag (fun targets command -> target_of_command venv pos loc command :: targets) [] in Omake_value.concat_array targets | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{project-directories} * * \begin{verbatim} * $(project-directories) : Dir Array * \end{verbatim} * * The \verb+project-directories+ function returns the list of all directories * that are considered to be part of the project. * * To get the complete directory list, this function should be called * from within a rule body. * \end{doc} *) let project_directories venv pos loc args = let pos = string_pos "project-directories" pos in match args with [] -> let dirs = Omake_node.DirTable.fold (fun dirs dir _ -> Omake_value_type.ValDir dir :: dirs) [] (Omake_env.venv_directories venv) in Omake_value_type.ValArray (List.rev dirs) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 0, List.length args))) (* * \begin{doc} * \fun{rule} * * The \verb+rule+ function is called whenever a build rule is defined. * It is unlikely that you will need to redefine this function, except in * very exceptional cases. * * \begin{verbatim} * rule(multiple, target, pattern, sources, options, body) : Rule * multiple : String * target : Sequence * pattern : Sequence * sources : Sequence * options : Array * body : Body * \end{verbatim} * * The \verb+rule+ function is called when a rule is evaluated. * * \begin{description} * \item[multiple] A Boolean value indicating whether the rule was defined * with a double colon \verb+::+. * \item[target] The sequence of target names. * \item[pattern] The sequence of patterns. This sequence will be empty * for two-part rules. * \item[sources] The sequence of dependencies. * \item[options] An array of options. Each option is represented * as a \hyperobj{Map} associating each specified option with * a value. * \item[body] The body expression of the rule. * \end{description} * * Consider the following rule. * * \begin{verbatim} * target: pattern: sources :name1: option1 :name2: option2 * expr1 * expr2 * \end{verbatim} * * This expression represents the following function call, where * square brackets are used to indicate arrays, and the curly * brackets represent a \hyperobj{Map}. * * \begin{verbatim} * rule(false, target, pattern, sources, * { $|:name1:| = option1; $|:name2:| = option2 } * [expr1; expr2]) * \end{verbatim} * \end{doc} *) let rule_fun venv pos loc args kargs = let pos = string_pos "rule_fun" pos in match args, kargs with |[multiple; target; pattern; source; options; body], [] -> let multiple = Omake_eval.bool_of_value venv pos multiple in Omake_rule.eval_rule_exp venv pos loc multiple target pattern source options body | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 6, List.length args))) (* * This is called whenever a .STATIC: ... or a .MEMO: ... rule is evaluated. * It isn't clear whether we want to document this. *) let memo_rule_fun venv pos loc args kargs = let pos = string_pos "memo_rule_fun" pos in match args, kargs with [multiple; is_static; node; index; key; vars; source; options; body], [] -> let multiple = Omake_eval.bool_of_value venv pos multiple in let is_static = Omake_eval.bool_of_value venv pos is_static in let key = Omake_eval.values_of_value venv pos key in let key = Omake_value.key_of_value venv pos (ValArray (node :: index ::key)) in let vars = Omake_value.vars_of_value venv pos vars in let target = Omake_value.file_of_value venv pos node in let venv = Omake_rule.eval_memo_rule_exp venv pos loc multiple is_static key vars target source options body in venv, Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 9, List.length args))) (* * \begin{doc} * \fun{build} * * \begin{verbatim} * build(targets : File Array) : bool * \end{verbatim} * * Build the given targets. The value is true iff the build was successful. * This function can be used only in \verb+osh+. * \end{doc} *) let build venv pos loc args = let pos = string_pos "build" pos in if not (Omake_env.venv_options venv).osh then raise (Omake_value_type.OmakeException (pos, StringError "build can be called only from osh")); match args with [arg] -> let targets = Omake_eval.strings_of_value venv pos arg in let b = try Omake_build.build_fun venv targets with exn -> Omake_eval.raise_uncaught_exception pos exn in if b then Omake_builtin_util.val_true else Omake_builtin_util.val_false | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (************************************************************************ * Hooks. *) let () = let builtin_funs = [true, "target", target, Omake_ir.ArityExact 1; true, "target-optional", target_optional, ArityExact 1; true, "dependencies", dependencies, ArityExact 1; true, "dependencies-all", dependencies_all, ArityExact 1; true, "dependencies-proper", dependencies_proper, ArityExact 1; true, "project-directories", project_directories, ArityExact 0; true, "find-build-targets", find_build_targets, ArityExact 1; true, "build", build, ArityExact 1; ] in let builtin_kfuns = [true, "rule", rule_fun, Omake_ir.ArityExact 6; true, "memo-rule", memo_rule_fun, ArityExact 9; ] in let pervasives_objects = ["Target"] in let builtin_info = { Omake_builtin_type.builtin_empty with builtin_funs = builtin_funs; builtin_kfuns = builtin_kfuns; pervasives_objects = pervasives_objects } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_builtin_object.ml0000644000175000017500000010372113177364665020300 0ustar gerdgerd include Omake_pos.Make (struct let name = "Omake_builtin_object" end) (* * Extend an object with another. * The argument may be a file or an object. *) let extends_fun venv pos loc args _ = let pos = string_pos "extends" pos in let extend_arg venv v = let obj = match Omake_eval.eval_value venv pos v with ValObject obj -> obj | v -> Omake_build_util.object_of_file venv pos loc (Omake_eval.string_of_value venv pos v) in Omake_env.venv_include_object venv obj in let venv = List.fold_left extend_arg venv args in venv, Omake_value_type.ValNone (* * Get the object form of a value. *) let object_fun venv pos loc args = let pos = string_pos "object" pos in let values = match args with [arg] -> Omake_eval.values_of_value venv pos arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let values = List.map (fun v -> Omake_value_type.ValObject (Omake_eval.eval_object venv pos v)) values in Omake_value.concat_array values (************************************************************************ * Object operations. *) (* * Field membership. *) let object_mem venv pos loc args = let pos = string_pos "object-mem" pos in match args with [arg; v] -> let obj = Omake_eval.eval_object venv pos arg in let s = Omake_eval.string_of_value venv pos v in let v = Lm_symbol.add s in Omake_builtin_util.val_of_bool (Omake_env.venv_defined_field venv obj v) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let object_find venv pos loc args = let pos = string_pos "object-find" pos in match args with [arg; v] -> let obj = Omake_eval.eval_object venv pos arg in let s = Omake_eval.string_of_value venv pos v in let v = Lm_symbol.add s in Omake_env.venv_find_field venv obj pos v | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Add a field to an object. *) let object_add venv pos loc args kargs = let pos = string_pos "object-add" pos in match args, kargs with [arg; v; x], [] -> let obj = Omake_eval.eval_object venv pos arg in let s = Omake_eval.string_of_value venv pos v in let v = Lm_symbol.add s in let venv, obj = Omake_env.venv_add_field venv obj pos v x in venv, Omake_value_type.ValObject obj | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Add a field to an object. *) let object_length venv pos loc args = let pos = string_pos "object-length" pos in match args with | [arg] -> let obj = Omake_eval.eval_object venv pos arg in Omake_value_type.ValInt (Omake_env.venv_object_length obj) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Iterate over the object. *) let object_map venv pos loc args _ = let pos = string_pos "map" pos in let pos = string_pos "map" pos in let f, env, obj = match args with [arg; fun_val] -> let obj = Omake_eval.eval_object venv pos arg in let fun_val = Omake_eval.eval_value venv pos fun_val in let _, f = Omake_eval.eval_fun ~caller_env:true venv pos fun_val in let env = Omake_eval.definition_env_of_fun venv pos fun_val in f, env, obj | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in (* If the body exports the environment, preserve it across calls *) let init_venv = Omake_env.venv_with_env venv env in let venv, obj = Omake_env.venv_object_fold_internal (fun (venv, obj) v x -> let venv, x = f venv pos loc [ValString (Lm_symbol.to_string v); x] [] in let obj = Omake_env.venv_add_field_internal obj v x in venv, obj) (init_venv, obj) obj in venv, Omake_value_type.ValObject obj (* * instanceof predicate. *) let object_instanceof venv pos loc args = let pos = string_pos "instanceof" pos in let obj, v = match args with [obj; v] -> obj, v | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in let obj = Omake_eval.eval_object venv pos obj in let v = Lm_symbol.add (Omake_eval.string_of_value venv pos v) in if Omake_env.venv_instanceof obj v then Omake_builtin_util.val_true else Omake_builtin_util.val_false (************************************************************************ * Map operations. *) (* * Map manipulation. *) let map_of_object _ pos obj = try match Omake_env.venv_find_field_internal_exn obj Omake_symbol.map_sym with ValMap map -> map | _ -> raise Not_found with Not_found -> raise (Omake_value_type.OmakeException (pos, StringError "object is not a Map")) let map_of_value venv pos arg = let obj = Omake_eval.eval_object venv pos arg in map_of_object venv pos obj let wrap_map obj map = Omake_value_type.ValObject (Omake_env.venv_add_field_internal obj Omake_symbol.map_sym (ValMap map)) (* * Field membership. *) let map_mem venv pos loc args = let pos = string_pos "map-mem" pos in match args with [arg; v] -> let map = map_of_value venv pos arg in let v = Omake_value.key_of_value venv pos v in Omake_builtin_util.val_of_bool (Omake_env.venv_map_mem map pos v) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let map_find venv pos loc args = let pos = string_pos "map-find" pos in match args with [arg; v] -> let map = map_of_value venv pos arg in let v = Omake_value.key_of_value venv pos v in Omake_env.venv_map_find map pos v | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Get the number of elements in the map. *) let map_length venv pos loc args = let pos = string_pos "map-length" pos in match args with [arg] -> let map = map_of_value venv pos arg in Omake_value_type.ValInt (Omake_env.venv_map_length map) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Add a field to an object. *) let map_add venv pos loc args = let pos = string_pos "map-add" pos in match args with [arg; v; x] -> let obj = Omake_eval.eval_object venv pos arg in let map = map_of_object venv pos obj in let key = Omake_value.key_of_value venv pos v in wrap_map obj (Omake_env.venv_map_add map pos key x) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Remove a field from an object. *) let map_remove venv pos loc args = let pos = string_pos "map-remove" pos in match args with [arg; v] -> let obj = Omake_eval.eval_object venv pos arg in let map = map_of_object venv pos obj in let key = Omake_value.key_of_value venv pos v in wrap_map obj (Omake_env.venv_map_remove map pos key) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Iterate over the object. *) let map_map venv pos loc args kargs = let pos = string_pos "map-map" pos in let f, env, obj, map = match args, kargs with [arg; fun_val], [] -> let obj = Omake_eval.eval_object venv pos arg in let map = map_of_object venv pos obj in let fun_val = Omake_eval.eval_value venv pos fun_val in let _, f = Omake_eval.eval_fun ~caller_env:true venv pos fun_val in let env = Omake_eval.definition_env_of_fun venv pos fun_val in f, env, obj, map | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in (* If the body exports the environment, preserve it across calls *) let init_venv = Omake_env.venv_with_env venv env in let venv, map = Omake_env.venv_map_fold (fun (venv, map) v x -> let venv, x = f venv pos loc [v; x] [] in let map = Omake_env.venv_map_add map pos v x in venv, map) (init_venv, map) map in venv, wrap_map obj map (* * Get an array of keys of the map. *) let map_keys venv pos loc args = let pos = string_pos "map-keys" pos in match args with | [arg] -> let map = map_of_value venv pos arg in let keys = Omake_env.venv_map_fold (fun keys k _ -> k::keys) [] map in Omake_value_type.ValArray (List.rev keys) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Get an array of values of the map. *) let map_values venv pos loc args = let pos = string_pos "map-values" pos in match args with [arg] -> let map = map_of_value venv pos arg in let vals = Omake_env.venv_map_fold (fun vals _ v -> v::vals) [] map in Omake_value_type.ValArray (List.rev vals) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \twofuns{create-map}{create-lazy-map} * * The \verb+create-map+ is a simplified form for creating \verb+Map+ objects. * The \verb+create-map+ function takes an even number of arguments that specify * key/value pairs. For example, the following values are equivalent. * * \begin{verbatim} * X = $(create-map name1, xxx, name2, yyy) * * X. = * extends $(Map) * $|name1| = xxx * $|name2| = yyy * \end{verbatim} * * The \verb+create-lazy-map+ function is similar, but the values are computed * lazily. The following two definitions are equivalent. * * \begin{verbatim} * Y = $(create-lazy-map name1, $(xxx), name2, $(yyy)) * * Y. = * extends $(Map) * $|name1| = $`(xxx) * $|name2| = $`(yyy) * \end{verbatim} * * The \hyperfun{create-lazy-map} is used in rule construction. * \end{doc} *) let create_map venv pos loc args = let pos = string_pos "create-map" pos in let rec collect map args = match args with key :: value :: args -> let key = Omake_value_type.ValData (Omake_eval.string_of_value venv pos key) in let map = Omake_env.venv_map_add map pos key value in collect map args | [_] -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError ("create-map requires an even number of arguments"))) | [] -> map in Omake_value_type.ValMap (collect Omake_env.venv_map_empty args) (************************************************************************ * Generic sequence operations. *) (* * Return the number of elements in the sequence. *) let int_of_arity (arity : Omake_ir.arity) = match arity with | ArityExact i | ArityRange (i, _) -> i | ArityNone -> 0 | ArityAny -> max_int let sequence_length venv pos loc args = let pos = string_pos "length" pos in match args with | [arg] -> let obj = Omake_eval.eval_object venv pos arg in let arg = Omake_value.eval_object_value venv pos obj in let len = match arg with ValMap map -> Omake_env.venv_map_length map | ValObject obj -> Omake_env.venv_object_length obj | ValNone | ValWhite _ -> 0 | ValInt _ | ValFloat _ | ValNode _ | ValDir _ | ValBody _ | ValChannel _ -> 1 | ValData s -> String.length s | ValQuote vl -> String.length (Omake_eval.string_of_quote venv pos None vl) | ValQuoteString (c, vl) -> String.length (Omake_eval.string_of_quote venv pos (Some c) vl) | ValSequence _ | ValString _ -> List.length (Omake_eval.values_of_value venv pos arg) | ValArray a -> List.length a | ValFun (_, keywords, params, _, _) -> int_of_arity (Omake_value_print.fun_arity keywords params) | ValFunCurry (_, curry_args, keywords, params, _, _, curry_kargs) -> int_of_arity (Omake_value_print.curry_fun_arity curry_args keywords params curry_kargs) | ValPrim (arity, _, _, _) | ValPrimCurry (arity, _, _, _, _) -> int_of_arity arity | ValRules l -> List.length l | ValCases cases -> List.length cases | ValClass _ | ValOther _ | ValVar _ -> 0 | ValStringExp _ | ValMaybeApply _ | ValDelayed _ -> raise (Invalid_argument "Omake_builtin_error.sequence_length") in Omake_value_type.ValInt len | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Get the nth element of a sequence. *) let sequence_nth venv pos loc args = let pos = string_pos "nth" pos in match args with [arg; i] -> let i = Omake_value.int_of_value venv pos i in let obj = Omake_eval.eval_object venv pos arg in let arg = Omake_value.eval_object_value venv pos obj in (match arg with ValNone | ValWhite _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValStringExp _ | ValMaybeApply _ | ValDelayed _ | ValMap _ | ValObject _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))) | ValInt _ | ValFloat _ | ValNode _ | ValDir _ | ValBody _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValVar _ -> if i = 0 then arg else raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))) | ValData s -> let len = String.length s in if i < 0 || i >= len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))); ValData (String.sub s i 1) | ValQuote vl -> let s = Omake_eval.string_of_quote venv pos None vl in let len = String.length s in if i < 0 || i >= len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))); ValData (String.sub s i 1) | ValQuoteString (c, vl) -> let s = Omake_eval.string_of_quote venv pos (Some c) vl in let len = String.length s in if i < 0 || i >= len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))); ValData (String.sub s i 1) | ValSequence _ | ValString _ -> let values = Omake_eval.values_of_value venv pos arg in let len = List.length values in if i < 0 || i >= len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))); List.nth values i | ValArray a -> let len = List.length a in if i < 0 || i >= len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))); List.nth a i | ValRules l -> let len = List.length l in if i < 0 || i >= len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))); ValRules [List.nth l i]) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Test if a sequence is nonempty. *) let sequence_nth_tl venv pos loc args = let pos = string_pos "nth-tl" pos in match args with [arg; i] -> let i = Omake_value.int_of_value venv pos i in let obj = Omake_eval.eval_object venv pos arg in let arg = Omake_value.eval_object_value venv pos obj in (match arg with ValNone | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValMaybeApply _ | ValDelayed _ | ValMap _ | ValObject _ | ValInt _ | ValFloat _ | ValNode _ | ValDir _ | ValStringExp _ | ValBody _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValVar _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))) | ValData s -> let len = String.length s in if i < 0 || i > len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))); Omake_value_type.ValData (String.sub s i (String.length s - i)) | ValQuote vl -> let s = Omake_eval.string_of_quote venv pos None vl in let len = String.length s in if i < 0 || i > len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))); ValData (String.sub s i (String.length s - i)) | ValQuoteString (c, vl) -> let s = Omake_eval.string_of_quote venv pos (Some c) vl in let len = String.length s in if i < 0 || i > len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))); ValData (String.sub s i (String.length s - i)) | ValSequence _ | ValWhite _ | ValString _ -> let values = Omake_eval.values_of_value venv pos arg in let len = List.length values in if i < 0 || i > len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))); ValArray (Lm_list_util.nth_tl i values) | ValArray a -> let len = List.length a in if i < 0 || i > len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))); ValArray (Lm_list_util.nth_tl i a) | ValRules l -> let len = List.length l in if i < 0 || i > len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", i))); ValRules (Lm_list_util.nth_tl i l)) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Get the nth-tl of a sequence. *) let sequence_nonempty venv pos loc args = let pos = string_pos "is-nonempty" pos in let b = match args with [arg] -> let obj = Omake_eval.eval_object venv pos arg in let arg = Omake_value.eval_object_value venv pos obj in (match arg with ValNone | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValStringExp _ | ValMaybeApply _ | ValDelayed _ | ValMap _ | ValObject _ -> true | ValInt _ | ValFloat _ | ValNode _ | ValDir _ | ValBody _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValWhite _ | ValVar _ -> false | ValData s -> String.length s <> 0 | ValQuote vl -> let s = Omake_eval.string_of_quote venv pos None vl in String.length s <> 0 | ValQuoteString (c, vl) -> let s = Omake_eval.string_of_quote venv pos (Some c) vl in String.length s <> 0 | ValSequence _ | ValString _ -> Omake_eval.values_of_value venv pos arg <> [] | ValArray a -> a <> [] | ValRules l -> l <> []) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in if b then Omake_builtin_util.val_true else Omake_builtin_util.val_false (* * Subrange. *) let sequence_sub venv pos loc args = let pos = string_pos "sub" pos in match args with [arg; off; len] -> let off = Omake_value.int_of_value venv pos off in let len = Omake_value.int_of_value venv pos len in let obj = Omake_eval.eval_object venv pos arg in let arg = Omake_value.eval_object_value venv pos obj in (match arg with ValNone | ValWhite _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValMaybeApply _ | ValDelayed _ | ValMap _ | ValObject _ | ValInt _ | ValFloat _ | ValNode _ | ValDir _ | ValStringExp _ | ValBody _ | ValChannel _ | ValClass _ | ValCases _ | ValOther _ | ValVar _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", off))) | ValData s -> let length = String.length s in if off < 0 || len < 0 || off + len >= length then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", off))); Omake_value_type.ValData (String.sub s off len) | ValQuote vl -> let s = Omake_eval.string_of_quote venv pos None vl in let length = String.length s in if off < 0 || len < 0 || off + len >= length then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", off))); ValData (String.sub s off len) | ValQuoteString (c, vl) -> let s = Omake_eval.string_of_quote venv pos (Some c) vl in let length = String.length s in if off < 0 || len < 0 || off + len >= length then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", off))); ValData (String.sub s off len) | ValSequence _ | ValString _ -> let values = Omake_eval.values_of_value venv pos arg in let length = List.length values in if off < 0 || len < 0 || off + len >= length then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", off))); ValArray (Lm_list_util.sub values off len) | ValArray values -> let length = List.length values in if off < 0 || len < 0 || off + len >= length then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", off))); ValArray (Lm_list_util.sub values off len) | ValRules values -> let length = List.length values in if off < 0 || len < 0 || off + len >= length then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("out of bounds", off))); ValRules (Lm_list_util.sub values off len)) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 3, List.length args))) (* * Reverse the elements in the sequence. *) let sequence_rev venv pos loc args = let pos = string_pos "rev" pos in match args with [arg] -> let obj = Omake_eval.eval_object venv pos arg in let arg = Omake_value.eval_object_value venv pos obj in (match arg with ValNone | ValWhite _ | ValFun _ | ValFunCurry _ | ValPrim _ | ValPrimCurry _ | ValMaybeApply _ | ValDelayed _ | ValMap _ | ValObject _ | ValInt _ | ValFloat _ | ValNode _ | ValDir _ | ValStringExp _ | ValBody _ | ValChannel _ | ValClass _ | ValOther _ | ValVar _ -> arg | ValData s1 -> let len = String.length s1 in let s2 = Bytes.create len in for i = 0 to len - 1 do Bytes.set s2 i (s1.[len - i - 1]) done; ValData (Bytes.to_string s2) | ValQuote vl -> let s1 = Omake_eval.string_of_quote venv pos None vl in let len = String.length s1 in let s2 = Bytes.create len in for i = 0 to len - 1 do Bytes.set s2 i (s1.[len - i - 1]) done; ValData (Bytes.to_string s2) | ValQuoteString (c, vl) -> let s1 = Omake_eval.string_of_quote venv pos (Some c) vl in let len = String.length s1 in let s2 = Bytes.create len in for i = 0 to len - 1 do Bytes.set s2 i (s1.[len - i - 1]) done; ValData (Bytes.to_string s2) | ValCases cases -> ValCases (List.rev cases) | ValSequence _ | ValString _ -> let values = Omake_eval.values_of_value venv pos arg in ValArray (List.rev values) | ValArray a -> ValArray (List.rev a) | ValRules l -> ValRules (List.rev l)) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 0, List.length args))) (* * Map. * * \begin{doc} * \section{Iteration and mapping} * * \fun{foreach} * * The \verb+foreach+ function maps a function over a sequence. * * \begin{verbatim} * $(foreach , ) * * foreach( => ..., ) * * \end{verbatim} * * For example, the following program defines the variable \verb+X+ * as an array \verb+a.c b.c c.c+. * * \begin{verbatim} * X = * foreach(x => ..., a b c) * value $(x).c * * # Equivalent expression * X = $(foreach $(fun x => ..., $(x).c), a b c) * \end{verbatim} * * There is also an abbreviated syntax. * * The \verb+export+ form can also be used in a \verb+foreach+ * body. The final value of \verb+X+ is \verb+a.c b.c c.c+. * * \begin{verbatim} * X = * foreach(x => ..., a b c) * X += $(x).c * export * \end{verbatim} * * The \hyperfun{break} can be used to break out of the loop early. * \end{doc} *) let foreach_fun venv pos loc args kargs = let pos = string_pos "foreach" pos in let f, env, args = match args, kargs with | [fun_val; arg], [] -> let args = Omake_eval.values_of_value venv pos arg in let fun_val = Omake_eval.eval_value venv pos fun_val in let _, f = Omake_eval.eval_fun ~caller_env:true venv pos fun_val in let env = Omake_eval.definition_env_of_fun venv pos fun_val in f, env, args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in (* If the body exports the environment, preserve it across calls *) let init_venv = Omake_env.venv_with_env venv env in let venv, values = List.fold_left (fun (venv, values) v -> let venv, x = f venv pos loc [v] [] in venv, x :: values) (init_venv, []) args in venv, Omake_value_type.ValArray (List.rev values) (* * \begin{doc} * \section{Boolean tests} * * \fun{sequence-forall} * * The \verb+forall+ function tests whether a predicate holds for each * element of a sequence. * * \begin{verbatim} * $(sequence-forall , ) * * sequence-forall( => ..., ) * * \end{verbatim} * \end{doc} *) let forall_fun venv pos loc args kargs = let pos = string_pos "sequence-forall" pos in let f, args = match args, kargs with [fun_val; arg], [] -> let args = Omake_eval.values_of_value venv pos arg in let _, f = Omake_eval.eval_fun venv pos fun_val in f, args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in let rec test venv args = match args with arg :: args -> let venv, result = f venv pos loc [arg] [] in if Omake_eval.bool_of_value venv pos result then test venv args else venv, false | [] -> venv, true in let venv, x = test venv args in let x = if x then Omake_builtin_util.val_true else Omake_builtin_util.val_false in venv, x (* * \begin{doc} * \subsection{sequence-exists} * * The \verb+exists+ function tests whether a predicate holds for * some element of a sequence. * * \begin{verbatim} * $(sequence-exists , ) * * sequence-exists( => ..., ) * * \end{verbatim} * \end{doc} *) let exists_fun venv pos loc args kargs = let pos = string_pos "sequence-exists" pos in let f, args = match args, kargs with [fun_val; arg], [] -> let args = Omake_eval.values_of_value venv pos arg in let _, f = Omake_eval.eval_fun venv pos fun_val in f, args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in (* If the body exports the environment, preserve it across calls *) let rec test venv args = match args with |arg :: args -> let venv, result = f venv pos loc [arg] [] in if Omake_eval.bool_of_value venv pos result then venv, true else test venv args | [] -> venv, false in let venv, x = test venv args in let x = if x then Omake_builtin_util.val_true else Omake_builtin_util.val_false in venv, x (* * \begin{doc} * \fun{sequence-sort} * * The \verb+sort+ function sorts the elements in an array, * given a comparison function. Given two elements (x, y), * the comparison should return a negative number if x < y; * a positive number if x > y; and 0 if x = y. * * \begin{verbatim} * $(sequence-sort , ) * * sort(, => ..., ) * * \end{verbatim} * \end{doc} *) let sort_fun venv pos loc args kargs = let pos = string_pos "sequence-sort" pos in let f, args = match args, kargs with [fun_val; arg], [] -> let args = Omake_eval.values_of_value venv pos arg in let _, f = Omake_eval.eval_fun venv pos fun_val in f, args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in let compare v1 v2 = let _, x = f venv pos loc [v1; v2] [] in Omake_value.int_of_value venv pos x in let args = List.sort compare args in venv, Omake_value_type.ValArray args (* * \begin{doc} * \fun{compare} * * The \verb+compare+ function compares two values (x, y) generically * returning a negative number if x < y; * a positive number if x > y; and 0 if x = y. * * \begin{verbatim} * $(compare x, y) : Int * \end{verbatim} * \end{doc} *) let compare_fun _ pos loc args = let pos = string_pos "compare" pos in let x, y = match args with [x; y] -> x, y | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in Omake_value_type.ValInt (Omake_value_util.ValueCompare.compare x y) (* * Printable location. *) let string_of_location venv pos loc args = let pos = string_pos "string-of-location" pos in match args with [arg] -> let obj = Omake_eval.eval_object venv pos arg in let arg = Omake_value.eval_object_value venv pos obj in (match arg with ValOther (ValLocation loc) -> Omake_value_type.ValData (Lm_location.string_of_location loc) | _ -> raise (Omake_value_type.OmakeException (pos, StringValueError ("not a location", arg)))) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (************************************************************************ * Define the functions. *) (* * Add only the builtin functions. * The Pervasives file defines most of the remaining methods. *) let () = let builtin_funs = [true, "object", object_fun, Omake_ir.ArityExact 1; true, "obj-find", object_find, ArityExact 2; true, "obj-mem", object_mem, ArityExact 2; true, "obj-length", object_length, ArityExact 1; true, "obj-instanceof", object_instanceof, ArityExact 2; true, "map-add", map_add, ArityExact 3; true, "map-find", map_find, ArityExact 2; true, "map-mem", map_mem, ArityExact 2; true, "map-length", map_length, ArityExact 1; true, "map-remove", map_remove, ArityExact 1; true, "map-keys", map_keys, ArityExact 1; true, "map-values", map_values, ArityExact 1; true, "sequence-length", sequence_length, ArityExact 1; true, "sequence-nth", sequence_nth, ArityExact 2; true, "sequence-nth-tl", sequence_nth_tl, ArityExact 2; true, "sequence-nonempty", sequence_nonempty, ArityExact 1; true, "sequence-rev", sequence_rev, ArityExact 1; true, "sequence-sub", sequence_sub, ArityExact 3; true, "create-map", create_map, ArityAny; false, "create-lazy-map", create_map, ArityAny; true, "compare", compare_fun, ArityExact 2; true, "string-of-location", string_of_location, ArityExact 1 ] in let builtin_kfuns = [true, "obj-add", object_add, Omake_ir.ArityExact 3; true, "extends", extends_fun, ArityExact 1; true, "foreach", foreach_fun, ArityExact 2; true, "obj-map", object_map, ArityRange (3, 4); true, "map-map", map_map, ArityRange (3, 4); true, "sequence-map", foreach_fun, ArityRange (2, 3); true, "sequence-forall", forall_fun, ArityExact 2; true, "sequence-exists", exists_fun, ArityExact 2; true, "sequence-sort", sort_fun, ArityExact 2; ] in let builtin_vars = ["empty-map", (fun _ -> Omake_value_type.ValMap Omake_env.venv_map_empty)] in let builtin_objects = ["Int", Omake_symbol.value_sym, Omake_value_type.ValInt 0; "Float", Omake_symbol.value_sym, ValFloat 0.0; "String", Omake_symbol.value_sym, ValNone; "Array", Omake_symbol.value_sym, ValArray []; "Fun", Omake_symbol.value_sym, ValFun (Omake_env.venv_empty_env, [], [], [], ExportNone); "Rule", Omake_symbol.value_sym, ValRules []; "File", Omake_symbol.value_sym, ValNone; "Dir", Omake_symbol.value_sym, ValNone; "Body", Omake_symbol.value_sym, ValNone; "InChannel", Omake_symbol.value_sym, ValNone; "OutChannel", Omake_symbol.value_sym, ValNone; "InOutChannel", Omake_symbol.value_sym, ValNone; "Map", Omake_symbol.map_sym, ValMap Omake_env.venv_map_empty] in let pervasives_objects = ["Object"; "Number"; "Sequence"; "Node"; "Channel"; "Exception"; "RuntimeException"; "UnbuildableException"; "Select"; "Pipe"; "Stat"; "Passwd"; "Group"; "Shell"; "Lexer"; "Parser"; "Location"; "Position"; ] in let builtin_info = {Omake_builtin_type.builtin_empty with builtin_funs = builtin_funs; builtin_kfuns = builtin_kfuns; builtin_vars = builtin_vars; builtin_objects = builtin_objects; pervasives_objects = pervasives_objects } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_builtin_io.ml0000644000175000017500000017133013177364665017442 0ustar gerdgerd(* * Builtin file operations. * * \begin{doc} * \section{IO functions} * \end{doc} *) include Omake_pos.Make (struct let name = "Omake_builtin_io" end) (* * Table of variables. * * \begin{doc} * \subsection{Standard channels} * * The following variables define the standard channels. * * \var{stdin} * * \begin{verbatim} * stdin : InChannel * \end{verbatim} * * The standard input channel, open for reading. * * \var{stdout} * \begin{verbatim} * stdout : OutChannel * \end{verbatim} * * The standard output channel, open for writing. * * \var{stderr} * \begin{verbatim} * stderr : OutChannel * \end{verbatim} * * The standard error channel, open for writing. * \end{doc} *) (* * \begin{doc} * \fun{open-in-string} * The \verb+open-in-string+ treats a string as if it were a file * and returns a channel for reading. * * \begin{verbatim} * $(open-in-string s) : Channel * s : String * \end{verbatim} * \end{doc} *) let open_in_string venv pos loc args = let pos = string_pos "open-in-string" pos in match args with [arg] -> let s = Omake_value.string_of_value venv pos arg in let fd = Lm_channel.of_string s in let chan = Omake_env.venv_add_channel venv fd in Omake_value_type.ValChannel (Lm_channel.InChannel, chan) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \twofuns{open-out-string}{out-contents} * The \verb+open-out-string+ creates a channel that writes to a * string instead of a file. The string may be retrieved with the * \verb+out-contents+ function. * * \begin{verbatim} * $(open-out-string) : Channel * $(out-contents chan) : String * chan : OutChannel * \end{verbatim} * \end{doc} *) let open_out_string venv pos loc args = let pos = string_pos "open-in-string" pos in match args with | [] -> let fd = Lm_channel.create_string () in let chan = Omake_env.venv_add_channel venv fd in Omake_value_type.ValChannel (Lm_channel.OutChannel, chan) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 0, List.length args))) let out_contents venv pos loc args = let pos = string_pos "out-contents" pos in match args with [fd] -> let outp = Omake_value.prim_channel_of_value venv pos fd in let outx = Omake_env.venv_find_channel venv pos outp in let s = Lm_channel.to_string outx in Omake_value_type.ValString s | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Open a file. * * \begin{doc} * \fun{fopen} * * The \verb+fopen+ function opens a file for reading or writing. * * \begin{verbatim} * $(fopen file, mode) : Channel * file : File * mode : String * \end{verbatim} * * The \verb+file+ is the name of the file to be opened. * The \verb+mode+ is a combination of the following characters. * \begin{description} * \item[r] Open the file for reading; it is an error if the file does not exist. * \item[w] Open the file for writing; the file is created if it does not exist. * \item[a] Open the file in append mode; the file is created if it does not exist. * \item[+] Open the file for both reading and writing. * \item[t] Open the file in text mode (default). * \item[b] Open the file in binary mode. * \item[n] Open the file in nonblocking mode. * \item[x] Fail if the file already exists. * \end{description} * * Binary mode is not significant on Unix systems, where * text and binary modes are equivalent. * \end{doc} *) let read_mode = 1 let write_mode = 2 let create_mode = 4 let append_mode = 8 let binary_mode = 16 let text_mode = 32 let nonblock_mode = 64 let excl_mode = 128 let fopen_mode pos loc s = let len = String.length s in let rec collect mode i = if i = len then mode else let bit = match s.[i] with ' ' | '\t' -> mode | 'r' -> read_mode | 'w' -> write_mode lor create_mode | 'a' -> append_mode lor write_mode | '+' -> read_mode lor write_mode | 'b' -> binary_mode | 't' -> text_mode | 'n' -> nonblock_mode | 'x' -> excl_mode | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("illegal file mode", s))) in let mode = mode lor bit in collect mode (succ i) in let mode = collect 0 0 in let () = if (mode land text_mode) <> 0 && (mode land binary_mode) <> 0 then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("can't specify both text and binary modes", s))) in let opt = if (mode land append_mode) <> 0 then [Unix.O_APPEND; Unix.O_CREAT] else if (mode land create_mode) <> 0 then [Unix.O_CREAT; Unix.O_TRUNC] else [] in let kind, opt = if (mode land read_mode) <> 0 && (mode land write_mode) <> 0 then Omake_value_type.InOutChannel, Unix.O_RDWR :: opt else if (mode land write_mode) <> 0 then OutChannel, Unix.O_WRONLY :: opt else InChannel, Unix.O_RDONLY :: opt in let opt = if (mode land excl_mode) <> 0 then Unix.O_EXCL :: opt else opt in let opt = if (mode land nonblock_mode) <> 0 then Unix.O_NONBLOCK :: opt else opt in kind, (mode land binary_mode) <> 0, opt let fopen venv pos loc args = let pos = string_pos "fopen" pos in match args with |[node; flags] -> let name = Omake_value.filename_of_value venv pos node in let kind, binary, flags = fopen_mode pos loc (Omake_value.string_of_value venv pos flags) in let fd = try Lm_unix_util.openfile name flags 0o666 with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (loc_pos loc pos, exn)) in let chan = Lm_channel.create name Lm_channel.FileChannel kind binary (Some fd) in Omake_value_type.ValChannel (kind, Omake_env.venv_add_channel venv chan) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Closing file descriptors. * * \begin{doc} * \fun{close} * * \begin{verbatim} * $(close channel...) * channel : Channel * \end{verbatim} * * The \verb+close+ function closes a file that was previously opened * with \verb+fopen+. * \end{doc} *) let close venv pos loc args = let pos = string_pos "close" pos in match args with |[arg] -> let args = Omake_value.values_of_value venv pos arg in List.iter (fun arg -> match Omake_value.eval_prim_value venv pos arg with | ValChannel (_, channel) -> Omake_env.venv_close_channel venv pos channel | arg -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringValueError ("not a file descriptor", arg)))) args; Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \twofuns{read}{input-line} * * \begin{verbatim} * $(read channel, amount) : String * $(input-line channel) : String * channel : InChannel * amount : Int * raises RuntimeException * \end{verbatim} * * The \verb+read+ function reads up to \verb+amount+ * bytes from an input channel, and returns * the data that was read. The \verb+input-line+ function reads a line from the file and returns the line read, without * the line terminator. If an end-of-file condition is reached, both functions raise a \verb+RuntimeException+ * exception. * \end{doc} *) let read venv pos loc args = let pos = string_pos "read" pos in match args with [fd; amount] -> let fd = Omake_value.channel_of_value venv pos fd in let amount = Omake_value.int_of_value venv pos amount in let s = Bytes.make amount '\000' in let count = try Lm_channel.read fd s 0 amount with Sys_error _ | Invalid_argument _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in if count = amount then Omake_value_type.ValData (Bytes.to_string s) else if count = 0 then raise (Omake_value_type.UncaughtException (pos, End_of_file)) else ValData (Bytes.sub_string s 0 count) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let input_line venv pos loc args = let pos = string_pos "input-line" pos in match args with |[fd] -> let fd = Omake_value.channel_of_value venv pos fd in let s = try Lm_channel.input_line fd with Sys_error _ | End_of_file | Invalid_argument _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValData s | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{write} * * \begin{verbatim} * $(write channel, buffer, offset, amount) : String * channel : OutChannel * buffer : String * offset : Int * amount : Int * $(write channel, buffer) : String * channel : OutChannel * buffer : String * raises RuntimeException * \end{verbatim} * * In the 4-argument form, the \verb+write+ function writes * bytes to the output channel \verb+channel+ from the \verb+buffer+, * starting at position \verb+offset+. Up to \verb+amount+ bytes * are written. The function returns the number of bytes that were * written. * * The 3-argument form is similar, but the \verb+offset+ is 0. * * In the 2-argument form, the \verb+offset+ is 0, and the \verb+amount+ * if the length of the \verb+buffer+. * * If an end-of-file condition is reached, * the function raises a \verb+RuntimeException+ exception. * \end{doc} *) let write venv pos loc args = let pos = string_pos "read" pos in let fd, buf, off, len = match args with | [fd; buf] -> fd, buf, None, None | [fd; buf; len] -> fd, buf, None, Some len | [fd; buf; off; len] -> fd, buf, Some off, Some len | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (2, 4), List.length args))) in let fd = Omake_value.channel_of_value venv pos fd in let buf = Omake_value.string_of_value venv pos buf in let off = match off with Some off -> Omake_value.int_of_value venv pos off | None -> 0 in let len = match len with Some len -> Omake_value.int_of_value venv pos len | None -> String.length buf in let count = try Lm_channel.write fd (Bytes.of_string buf) off len with Sys_error _ | Invalid_argument _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValInt count (* * \begin{doc} * \fun{lseek} * * \begin{verbatim} * $(lseek channel, offset, whence) : Int * channel : Channel * offset : Int * whence : String * raises RuntimeException * \end{verbatim} * * The \verb+lseek+ function repositions the offset of the * channel \verb+channel+ according to the \verb+whence+ directive, as * follows: * * \begin{description} * \item[SEEK\_SET] The offset is set to \verb+offset+. * \item[SEEK\_CUR] The offset is set to its current position plus \verb+offset+ bytes. * \item[SEEK\_END] The offset is set to the size of the file plus \verb+offset+ bytes. * \end{description} * * The \verb+lseek+ function returns the new position in the file. * \end{doc} *) let lseek venv pos loc args = let pos = string_pos "lseek" pos in match args with | [fd; off; whence] -> let fd = Omake_value.channel_of_value venv pos fd in let off = Omake_value.int_of_value venv pos off in let whence = match String.uppercase_ascii (Omake_value.string_of_value venv pos whence) with "SET" | "SEEK_SET" -> Unix.SEEK_SET | "CUR" | "CURRENT" | "SEEK_CUR" -> Unix.SEEK_CUR | "END" | "SEEK_END" -> Unix.SEEK_END | whence -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("illegal lseek parameter", whence))) in let off = try Lm_channel.seek fd off whence with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValInt off | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 3, List.length args))) (* * \begin{doc} * \fun{rewind} * * \begin{verbatim} * rewind(channel...) * channel : Channel * \end{verbatim} * * The \verb+rewind+ function set the current file position to the * beginning of the file. * \end{doc} *) let rewind venv pos loc args = let pos = string_pos "rewind" pos in match args with | [arg] -> let args = Omake_value.values_of_value venv pos arg in let () = try List.iter (fun arg -> let fd = Omake_value.channel_of_value venv pos arg in ignore (Lm_channel.seek fd 0 Unix.SEEK_SET)) args with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{tell} * * \begin{verbatim} * $(tell channel...) : Int... * channel : Channel * raises RuntimeException * \end{verbatim} * * The \verb+tell+ function returns the current position of the \verb+channel+. * \end{doc} *) let tell venv pos loc args = let pos = string_pos "tell" pos in match args with | [arg] -> let args = Omake_value.values_of_value venv pos arg in let args = try List.map (fun arg -> let fd = Omake_value.channel_of_value venv pos arg in Omake_value_type.ValInt (Lm_channel.tell fd)) args with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value.concat_array args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Flush an output channel. * * \begin{doc} * \fun{flush} * * \begin{verbatim} * $(flush channel...) * channel : OutChannel * \end{verbatim} * * The \verb+flush+ function can be used only on files that are open for writing. * It flushes all pending data to the file. * \end{doc} *) let flush venv pos loc args = let pos = string_pos "flush" pos in match args with | [arg] -> let args = Omake_value.values_of_value venv pos arg in List.iter (fun s -> let fd = Omake_value.channel_of_value venv pos s in Lm_channel.flush fd) args; Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{channel-name} * * \begin{verbatim} * $(channel-name channel...) : String * channel : Channel * \end{verbatim} * * The \verb+channel-name+ function returns the name that is associated with the channel. * \end{doc} *) let channel_name venv pos loc args = let pos = string_pos "channel-name" pos in match args with | [arg] -> let fd = Omake_value.channel_of_value venv pos arg in Omake_value_type.ValData (Lm_channel.name fd) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{dup} * * \begin{verbatim} * $(dup channel) : Channel * channel : Channel * raises RuntimeException * \end{verbatim} * * The \verb+dup+ function returns a new channel referencing the * same file as the argument. * \end{doc} *) let dup venv pos loc args = let pos = string_pos "dup" pos in match args with | [arg] -> let channel = Omake_value.channel_of_value venv pos arg in let name = Lm_channel.name channel in let fd = Lm_channel.descr channel in let _, kind, mode, binary = Lm_channel.info channel in let fd = try Unix.dup fd with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in let chan = Lm_channel.create name kind mode binary (Some fd) in let channel = Omake_env.venv_add_channel venv chan in Omake_value_type.ValChannel (mode, channel) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{dup2} * * \begin{verbatim} * dup2(channel1, channel2) * channel1 : Channel * channel2 : Channel * raises RuntimeException * \end{verbatim} * * The \verb+dup2+ function causes \verb+channel2+ to refer to the same * file as \verb+channel1+. * \end{doc} *) let dup2 venv pos loc args = let pos = string_pos "dup2" pos in match args with | [arg1; arg2] -> let channel1 = Omake_value.channel_of_value venv pos arg1 in let channel2 = Omake_value.channel_of_value venv pos arg2 in let fd1 = Lm_channel.descr channel1 in let fd2 = Lm_channel.descr channel2 in let () = try Unix.dup2 fd1 fd2 with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * \begin{doc} * \fun{set-nonblock} * * \begin{verbatim} * set-nonblock-mode(mode, channel...) * channel : Channel * mode : String * \end{verbatim} * * The \verb+set-nonblock-mode+ function sets the nonblocking flag on the * given channel. When IO is performed on the channel, and the operation * cannot be completed immediately, the operations raises a \verb+RuntimeException+. * \end{doc} *) let set_nonblock_mode venv pos loc args = let pos = string_pos "set_nonblock_mode" pos in match args with [mode; channel] -> let set_mode = if Omake_value.bool_of_value venv pos mode then Unix.set_nonblock else Unix.clear_nonblock in let channels = Omake_value.values_of_value venv pos channel in let () = try List.iter (fun channel -> let channel = Omake_value.channel_of_value venv pos channel in let fd = Lm_channel.descr channel in set_mode fd) channels with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * \begin{doc} * \fun{set-close-on-exec-mode} * * \begin{verbatim} * set-close-on-exec-mode(mode, channel...) * channel : Channel * mode : String * raises RuntimeException * \end{verbatim} * * The \verb+set-close-on-exec-mode+ function sets the close-on-exec * flags for the given channels. If the close-on-exec flag is set, the channel * is not inherited by child processes. Otherwise it is. * \end{doc} *) let set_close_on_exec_mode venv pos loc args = let pos = string_pos "set-close-on-exec-mode" pos in match args with | [mode; channel] -> let set_mode = if Omake_value.bool_of_value venv pos mode then Unix.set_close_on_exec else Unix.clear_close_on_exec in let channels = Omake_value.values_of_value venv pos channel in let () = try List.iter (fun channel -> let channel = Omake_value.channel_of_value venv pos channel in let fd = Lm_channel.descr channel in set_mode fd) channels with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * \begin{doc} * \fun{pipe} * * \begin{verbatim} * $(pipe) : Pipe * raises RuntimeException * \end{verbatim} * * The \verb+pipe+ function creates a \verb+Pipe+ object, which has two * fields. The \verb+read+ field is a channel that is opened for * reading, and the \verb+write+ field is a channel that is opened * for writing. * \end{doc} *) let pipe venv pos loc args = let pos = string_pos "pipe" pos in match args with [] -> let fd_read, fd_write = try Unix.pipe () with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in let read = Lm_channel.create "" Lm_channel.PipeChannel InChannel false (Some fd_read) in let write = Lm_channel.create "" Lm_channel.PipeChannel OutChannel false (Some fd_write) in let fd_read = Omake_value_type.ValChannel (InChannel, Omake_env.venv_add_channel venv read) in let fd_write = Omake_value_type.ValChannel (OutChannel, Omake_env.venv_add_channel venv write) in let obj = Omake_env.venv_find_object_or_empty venv Omake_var.pipe_object_var in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.read_sym fd_read in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.write_sym fd_write in Omake_value_type.ValObject obj | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 0, List.length args))) (* * \begin{doc} * \fun{mkfifo} * * \begin{verbatim} * mkfifo(mode, node...) * mode : Int * node : Node * \end{verbatim} * * The \verb+mkfifo+ function creates a named pipe. * \end{doc} *) let mkfifo venv pos loc args = let pos = string_pos "mkfifo" pos in match args with | [mode; nodes] -> let mode = Omake_value.int_of_value venv pos mode in let nodes = Omake_value.values_of_value venv pos nodes in let () = try List.iter (fun node -> Unix.mkfifo (Omake_value.filename_of_value venv pos node) mode) nodes with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * \begin{doc} * \fun{select} * * \begin{verbatim} * $(select rfd..., wfd..., wfd..., timeout) : Select * rfd : InChannel * wfd : OutChannel * efd : Channel * timeout : float * raises RuntimeException * \end{verbatim} * * The \verb+select+ function polls for possible IO on a set of channels. * The \verb+rfd+ are a sequence of channels for reading, \verb+wfd+ are a * sequence of channels for writing, and \verb+efd+ are a sequence of * channels to poll for error conditions. The \verb+timeout+ specifies * the maximum amount of time to wait for events. * * On successful return, \verb+select+ returns a \verb+Select+ object, * which has the following fields: * \begin{description} * \item[read] An array of channels available for reading. * \item[write] An array of channels available for writing. * \item[error] An array of channels on which an error has occurred. * \end{description} * \end{doc} *) let select venv pos loc args = let pos = string_pos "select" pos in match args with | [rfd; wfd; efd; timeout] -> let rfd = Omake_value.values_of_value venv pos rfd in let wfd = Omake_value.values_of_value venv pos wfd in let efd = Omake_value.values_of_value venv pos efd in let rfd = List.map (Omake_value.channel_of_value venv pos) rfd in let wfd = List.map (Omake_value.channel_of_value venv pos) wfd in let efd = List.map (Omake_value.channel_of_value venv pos) efd in let timeout = Omake_value.float_of_value venv pos timeout in let rfd, wfd, efd = try Lm_channel.select rfd wfd efd timeout with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in let reintern_channel fdl = List.map (fun fd -> let fd = Omake_env.venv_find_channel_by_channel venv pos fd in let channel = Omake_env.venv_find_channel venv pos fd in let _, _, mode, _ = Lm_channel.info channel in Omake_value_type.ValChannel (mode, fd)) fdl in let rfd = reintern_channel rfd in let wfd = reintern_channel wfd in let efd = reintern_channel efd in let obj = Omake_env.venv_find_object_or_empty venv Omake_var.select_object_var in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.read_sym (ValArray rfd) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.write_sym (ValArray wfd) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.error_sym (ValArray efd) in Omake_value_type.ValObject obj | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 4, List.length args))) (* * \begin{doc} * \fun{lockf} * * \begin{verbatim} * lockf(channel, command, len) * channel : Channel * command : String * len : Int * raises RuntimeException * \end{verbatim} * * The \verb+lockf+ function places a lock on a region of the channel. * The region starts at the current position and extends for \verb+len+ * bytes. * * The possible values for \verb+command+ are the following. * \begin{description} * \item[F\_ULOCK] Unlock a region. * \item[F\_LOCK] Lock a region for writing; block if already locked. * \item[F\_TLOCK] Lock a region for writing; fail if already locked. * \item[F\_TEST] Test a region for other locks. * \item[F\_RLOCK] Lock a region for reading; block if already locked. * \item[F\_TRLOCK] Lock a region for reading; fail is already locked. * \end{description} * \end{doc} *) let lockf venv pos loc args = let pos = string_pos "lockf" pos in match args with [channel; command; len] -> let channel = Omake_value.channel_of_value venv pos channel in let command = Omake_value.string_of_value venv pos command in let len = Omake_value.int_of_value venv pos len in let command = match command with | "F_ULOCK" -> Unix.F_ULOCK | "F_LOCK" -> Unix.F_LOCK | "F_TLOCK" -> Unix.F_TLOCK | "F_TEST" -> Unix.F_TEST | "F_RLOCK" -> Unix.F_RLOCK | "F_TRLOCK" -> Unix.F_TRLOCK | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("lockf: illegal command", command))) in let fd = Lm_channel.descr channel in let () = try Unix.lockf fd command len with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 3, List.length args))) (************************************************************************ * Databases. *) let addr_of_value venv pos arg = let host = Omake_value.string_of_value venv pos arg in try Unix.inet_addr_of_string host with Failure _ -> let entry = Unix.gethostbyname host in entry.Unix.h_addr_list.(0) let proto_of_value venv pos arg = let proto = Omake_value.string_of_value venv pos arg in try Unix.getprotobynumber (int_of_string proto) with Failure _ -> Unix.getprotobyname proto (* (* * \begin{doc} * \obj{InetAddr} * * The \verb+InetAddr+ object describes an Internet address. * It contains the following fields. * * \begin{description} * \item[addr] \verb+String+: the Internet address. * \item[port] \verb+Int+: the port number. * \end{description} * * \obj{Host} * * A \verb+Host+ object contains the following fields. * * \begin{description} * \item[name] \verb+String+: the name of the host. * \item[aliases] \verb+String Array+: other names by which the host is known. * \item[addrtype] \verb+String+: the preferred socket domain. * \item[addrs] \verb+InetAddr Array+: an array of Internet addresses belonging to the host. * \end{description} * * \fun{gethostbyname} * * \begin{verbatim} * $(gethostbyname host...) : Host... * host : String * raises RuntimeException * \end{verbatim} * * The \verb+gethostbyname+ function returns a \verb+Host+ object * for the specified host. The \verb+host+ may specify a domain name * or an Internet address. * * \end{doc} *) let gethostbyname venv pos loc args = let pos = string_pos "gethostbyname" pos in match args with [arg] -> let args = Omake_value.values_of_value venv pos arg in let args = try List.map (fun arg -> let host = Omake_value.string_of_value venv pos arg in let entry = try let addr = Unix.inet_addr_of_string host in Unix.gethostbyaddr addr with Failure _ -> Unix.gethostbyname host in make_host_entry venv pos entry) args with Not_found | Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value.concat_array args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \obj{Protocol} * * The \verb+Protocol+ object represents a protocol entry. * It has the following fields. * * \begin{description} * \item[name] \verb+String+: the canonical name of the protocol. * \item[aliases] \verb+String Array+: aliases for the protocol. * \item[proto] \verb+Int+: the protocol number. * \end{description} * * \fun{getprotobyname} * * \begin{verbatim} * $(getprotobyname name...) : Protocol... * name : Int or String * raises RuntimeException * \end{verbatim} * * The \verb+getprotobyname+ function returns a \verb+Protocol+ object for the * specified protocol. The \verb+name+ may be a protocol name, or a * protocol number. * \end{doc} *) let getprotobyname venv pos loc args = let pos = string_pos "getprotobyname" pos in match args with [arg] -> let args = Omake_value.values_of_value venv pos arg in let args = try List.map (fun arg -> let proto = Omake_value.string_of_value venv pos arg in let entry = try Unix.getprotobynumber (int_of_string proto) with Failure _ -> Unix.getprotobyname proto in make_proto_entry venv pos entry) args with Not_found | Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value.concat_array args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \obj{Service} * * The \verb+Service+ object represents a network service. * It has the following fields. * * \begin{description} * \item[name] \verb+String+: the name of the service. * \item[aliases] \verb+String Array+: aliases for the service. * \item[port] \verb+Int+: the port number of the service. * \item[proto] \verb+Protocol+: the protocol for the service. * \end{description} * * \fun{getservbyname} * * \begin{verbatim} * $(getservbyname service...) : Service... * service : String or Int * raises RuntimeException * \end{verbatim} * * The \verb+getservbyname+ function gets the information for a network service. * The \verb+service+ may be specified as a service name or number. * \end{doc} *) let getprotobyname venv pos loc args = let pos = string_pos "getprotobyname" pos in match args with [arg] -> let args = Omake_value.values_of_value venv pos arg in let args = try List.map (fun arg -> let proto = Omake_value.string_of_value venv pos arg in let entry = try Unix.getservbyprt (int_of_string proto) with Failure _ -> Unix.getservbyname proto in make_serv_entry venv pos entry) args with Not_found | Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value.concat_array args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) *) (* * \begin{doc} * \fun{socket} * * \begin{verbatim} * $(socket domain, type, protocol) : Channel * domain : String * type : String * protocol : String * raises RuntimeException * \end{verbatim} * * The \verb+socket+ function creates an unbound socket. * * The possible values for the arguments are as follows. * * The \verb+domain+ may have the following values. * \begin{description} * \item[PF\_UNIX or unix] Unix domain, available only on Unix systems. * \item[PF\_INET or inet] Internet domain, IPv4. * \item[PF\_INET6 or inet6] Internet domain, IPv6. * \end{description} * * The \verb+type+ may have the following values. * \begin{description} * \item[SOCK\_STREAM or stream] Stream socket. * \item[SOCK\_DGRAM or dgram] Datagram socket. * \item[SOCK\_RAW or raw] Raw socket. * \item[SOCK\_SEQPACKET or seqpacket] Sequenced packets socket * \end{description} * * The \verb+protocol+ is an \verb+Int+ or \verb+String+ that specifies * a protocol in the protocols database. * \end{doc} *) let socket venv pos loc args = let pos = string_pos "socket" pos in match args with | [domain; ty; proto] -> let domain = match String.uppercase_ascii (Omake_value.string_of_value venv pos domain) with "PF_UNIX" | "UNIX" -> Unix.PF_UNIX | "PF_INET" | "INET" | "IP" -> Unix.PF_INET (* If you are compiling with OCaml-3.07 or earlier, comment out these lines *) | "PF_INET6" | "INET6" | "IP6" -> Unix.PF_INET6 | domain -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("bad domain", domain))) in let ty = match String.uppercase_ascii (Omake_value.string_of_value venv pos ty) with "SOCK_STREAM" | "STREAM" -> Unix.SOCK_STREAM | "SOCK_DGRAM" | "DGRAM" -> Unix.SOCK_DGRAM | "SOCK_RAW" | "RAW" -> Unix.SOCK_RAW | "SOCK_SEQPACKET" | "SEQPACKET" -> Unix.SOCK_SEQPACKET | ty -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("bad type", ty))) in let proto = proto_of_value venv pos proto in let socket = try Unix.socket domain ty proto.Unix.p_proto with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in let channel = Lm_channel.create "" Lm_channel.SocketChannel Lm_channel.InOutChannel false (Some socket) in let channel = Omake_env.venv_add_channel venv channel in Omake_value_type.ValChannel (InOutChannel, channel) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 3, List.length args))) (* * \begin{doc} * \fun{bind} * * \begin{verbatim} * bind(socket, host, port) * socket : InOutChannel * host : String * port : Int * bind(socket, file) * socket : InOutChannel * file : File * raise RuntimeException * \end{verbatim} * * The \verb+bind+ function binds a socket to an address. * * The 3-argument form specifies an Internet connection, the \verb+host+ specifies a host name * or IP address, and the \verb+port+ is a port number. * * The 2-argument form is for \verb+Unix+ sockets. The \verb+file+ specifies the filename * for the address. * \end{doc} *) let bind venv pos loc args = let pos = string_pos "bind" pos in let socket, addr = match args with [socket; host; port] -> let host = addr_of_value venv pos host in let port = Omake_value.int_of_value venv pos port in let addr = Unix.ADDR_INET (host, port) in socket, addr | [socket; name] -> let name = Omake_value.filename_of_value venv pos name in let addr = Unix.ADDR_UNIX name in socket, addr | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (2, 3), List.length args))) in let socket = Omake_value.channel_of_value venv pos socket in let socket = Lm_channel.descr socket in let () = try Unix.bind socket addr with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone (* * \begin{doc} * \fun{listen} * * \begin{verbatim} * listen(socket, requests) * socket : InOutChannel * requests : Int * raises RuntimeException * \end{verbatim} * * The \verb+listen+ function sets up the socket for receiving up to \verb+requests+ number * of pending connection requests. * \end{doc} *) let listen venv pos loc args = let pos = string_pos "listen" pos in match args with [socket; requests] -> let socket = Omake_value.channel_of_value venv pos socket in let socket = Lm_channel.descr socket in let requests = Omake_value.int_of_value venv pos requests in let () = try Unix.listen socket requests with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * \begin{doc} * \fun{accept} * * \begin{verbatim} * $(accept socket) : InOutChannel * socket : InOutChannel * raises RuntimeException * \end{verbatim} * * The \verb+accept+ function accepts a connection on a socket. * \end{doc} *) let accept venv pos loc args = let pos = string_pos "accept" pos in match args with | [socket] -> let socket = Omake_value.channel_of_value venv pos socket in let socket = Lm_channel.descr socket in let socket, _ = try Unix.accept socket with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in let channel = Lm_channel.create "" Lm_channel.SocketChannel Lm_channel.InOutChannel false (Some socket) in let channel = Omake_env.venv_add_channel venv channel in Omake_value_type.ValChannel (InOutChannel, channel) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{connect} * * \begin{verbatim} * connect(socket, addr, port) * socket : InOutChannel * addr : String * port : int * connect(socket, name) * socket : InOutChannel * name : File * raise RuntimeException * \end{verbatim} * * The \verb+connect+ function connects a socket to a remote address. * * The 3-argument form specifies an Internet connection. * The \verb+addr+ argument is the Internet address of the remote host, * specified as a domain name or IP address. The \verb+port+ argument * is the port number. * * The 2-argument form is for Unix sockets. The \verb+name+ argument * is the filename of the socket. * \end{doc} *) let connect venv pos loc args = let pos = string_pos "connect" pos in let socket, addr = match args with [socket; host; port] -> let host = addr_of_value venv pos host in let port = Omake_value.int_of_value venv pos port in let addr = Unix.ADDR_INET (host, port) in socket, addr | [socket; name] -> let name = Omake_value.filename_of_value venv pos name in let addr = Unix.ADDR_UNIX name in socket, addr | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (2, 3), List.length args))) in let socket = Omake_value.channel_of_value venv pos socket in let socket = Lm_channel.descr socket in let () = try Unix.connect socket addr with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone (************************************************************************ * Buffered IO. *) (* * Get the next character. * * \begin{doc} * \fun{getchar} * * \begin{verbatim} * $(getc) : String * $(getc file) : String * file : InChannel or File * raises RuntimeException * \end{verbatim} * * The \verb+getc+ function returns the next character of a file. * If the argument is not specified, \verb+stdin+ is used as input. * If the end of file has been reached, the function returns \verb+false+. * \end{doc} *) let getc venv pos loc args = let pos = string_pos "getc" pos in let arg = match args with |[] -> Omake_env.venv_find_var venv pos loc Omake_var.stdin_var | [arg] -> arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (0, 1), List.length args))) in let inp, close_flag = Omake_value.in_channel_of_any_value venv pos arg in let inx = Omake_env.venv_find_channel venv pos inp in let s = try String.make 1 (Lm_channel.input_char inx) with End_of_file -> "false" in if close_flag then Omake_env.venv_close_channel venv pos inp; Omake_value_type.ValData s (* * Get the next line. * * \begin{doc} * \fun{gets} * * \begin{verbatim} * $(gets) : String * $(gets channel) : String * channel : InChannel or File * raises RuntimeException * \end{verbatim} * * The \verb+gets+ function returns the next line from a file. * The function returns the empty string if the end of file has been reached. * The line terminator is removed. * \end{doc} *) let gets venv pos loc args = let pos = string_pos "gets" pos in let arg = match args with |[] -> Omake_env.venv_find_var venv pos loc Omake_var.stdin_var | [arg] -> arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (0, 1), List.length args))) in let inp, close_flag = Omake_value.in_channel_of_any_value venv pos arg in let inx = Omake_env.venv_find_channel venv pos inp in let s = try Lm_channel.input_line inx with End_of_file -> "" in if close_flag then Omake_env.venv_close_channel venv pos inp; Omake_value_type.ValString s (* * Get the next line. * * \begin{doc} * \fun{fgets} * * \begin{verbatim} * $(fgets) : String * $(fgets channel) : String * channel : InChannel or File * raises RuntimeException * \end{verbatim} * * The \verb+fgets+ function returns the next line from a file that has been * opened for reading with \verb+fopen+. The function returns the empty string * if the end of file has been reached. The returned string is returned as * literal data. The line terminator is not removed. * \end{doc} *) let fgets venv pos loc args = let pos = string_pos "fgets" pos in let arg = match args with [] -> Omake_env.venv_find_var venv pos loc Omake_var.stdin_var | [arg] -> arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (0, 1), List.length args))) in let inp, close_flag = Omake_value.in_channel_of_any_value venv pos arg in let inx = Omake_env.venv_find_channel venv pos inp in let s = try Lm_channel.input_entire_line inx with End_of_file -> "" in if close_flag then Omake_env.venv_close_channel venv pos inp; Omake_value_type.ValData s (* * \begin{doc} * \section{Printing functions} * \funref{fprint} * \funref{print} * \funref{eprint} * \funref{fprintln} * \funref{println} * \funref{eprintln} * * Output is printed with the \verb+print+ and \verb+println+ functions. * The \verb+println+ function adds a terminating newline to the value being * printed, the \verb+print+ function does not. * * \begin{verbatim} * fprint(, ) * print() * eprint() * fprintln(, ) * println() * eprintln() * \end{verbatim} * * The \verb+fprint+ functions print to a file that has been previously opened with * \verb+fopen+. The \verb+print+ functions print to the standard output channel, and * the \verb+eprint+ functions print to the standard error channel. * \end{doc} *) let print_aux venv pos loc nl args = match args with | [fd; s] -> let outp, close_flag = Omake_value.out_channel_of_any_value venv pos fd in let outx = Omake_env.venv_find_channel venv pos outp in let s = Omake_value.string_of_value venv pos s in Lm_channel.output_string outx s; Lm_channel.output_string outx nl; Lm_channel.flush outx; if close_flag then Omake_env.venv_close_channel venv pos outp; Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let fprint venv pos loc args = let pos = string_pos "fprint" pos in print_aux venv pos loc "" args let print venv pos loc args = let pos = string_pos "print" pos in let stdout_fd = Omake_env.venv_find_var venv pos loc Omake_var.stdout_var in fprint venv pos loc (stdout_fd :: args) let eprint venv pos loc args = let pos = string_pos "eprint" pos in let stderr_fd = Omake_env.venv_find_var venv pos loc Omake_var.stderr_var in fprint venv pos loc (stderr_fd :: args) let fprintln venv pos loc args = let pos = string_pos "fprintln" pos in print_aux venv pos loc "\n" args let println venv pos loc args = let pos = string_pos "println" pos in let stdout_fd = Omake_env.venv_find_var venv pos loc Omake_var.stdout_var in fprintln venv pos loc (stdout_fd :: args) let eprintln venv pos loc args = let pos = string_pos "eprintln" pos in let stderr_fd = Omake_env.venv_find_var venv pos loc Omake_var.stderr_var in fprintln venv pos loc (stderr_fd :: args) (* * \begin{doc} * \section{Value printing functions} * \funref{fprintv} * \funref{printv} * \funref{eprintv} * \funref{fprintvln} * \funref{printvln} * \funref{eprintvln} * * Values can be printed with the \verb+printv+ and \verb+printvln+ functions. * The \verb+printvln+ function adds a terminating newline to the value being * printed, the \verb+printv+ function does not. * * \begin{verbatim} * fprintv(, ) * printv() * eprintv() * fprintvln(, ) * printvln() * eprintvln() * \end{verbatim} * * The \verb+fprintv+ functions print to a file that has been previously opened with * \verb+fopen+. The \verb+printv+ functions print to the standard output channel, and * the \verb+eprintv+ functions print to the standard error channel. * \end{doc} *) let printv_aux venv pos loc nl args = match args with [fd; s] -> let outp, close_flag = Omake_value.out_channel_of_any_value venv pos fd in let outx = Omake_env.venv_find_channel venv pos outp in let s = Omake_value_print.pp_print_value Format.str_formatter s; Format.flush_str_formatter () in Lm_channel.output_string outx s; Lm_channel.output_string outx nl; Lm_channel.flush outx; if close_flag then Omake_env.venv_close_channel venv pos outp; Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let fprintv venv pos loc args = let pos = string_pos "fprintv" pos in printv_aux venv pos loc "" args let printv venv pos loc args = let pos = string_pos "printv" pos in let stdout_fd = Omake_env.venv_find_var venv pos loc Omake_var.stdout_var in fprintv venv pos loc (stdout_fd :: args) let eprintv venv pos loc args = let pos = string_pos "eprintv" pos in let stderr_fd = Omake_env.venv_find_var venv pos loc Omake_var.stderr_var in fprintv venv pos loc (stderr_fd :: args) let fprintvln venv pos loc args = let pos = string_pos "fprintvln" pos in printv_aux venv pos loc "\n" args let printvln venv pos loc args = let pos = string_pos "printvln" pos in let stdout_fd = Omake_env.venv_find_var venv pos loc Omake_var.stdout_var in fprintvln venv pos loc (stdout_fd :: args) let eprintvln venv pos loc args = let pos = string_pos "eprintvln" pos in let stderr_fd = Omake_env.venv_find_var venv pos loc Omake_var.stderr_var in fprintvln venv pos loc (stderr_fd :: args) (************************************************************************ * Printf. *) module Args = struct type t = { print_venv : Omake_env.t; print_pos : Omake_value_type.pos; print_loc : Lm_location.t; print_fmt : Format.formatter; print_fd : Omake_value_type.prim_channel; print_channel : Lm_channel.t } type value = Omake_value_type.t (* * Create the buffers and channels. *) let create_channel venv pos loc channel = let fmt = Lm_printf.byte_formatter (Lm_channel.output_buffer channel) (fun () -> Lm_channel.flush channel) in let fd = Omake_env.venv_add_formatter_channel venv fmt in let channel = Omake_env.venv_find_channel venv pos fd in { print_venv = venv; print_pos = pos; print_loc = loc; print_fmt = fmt; print_fd = fd; print_channel = channel } let create_buffer venv pos loc buf = let fmt = Format.formatter_of_buffer buf in let fd = Omake_env.venv_add_formatter_channel venv fmt in let channel = Omake_env.venv_find_channel venv pos fd in { print_venv = venv; print_pos = pos; print_loc = loc; print_fmt = fmt; print_fd = fd; print_channel = channel } (* * When done, close the channels, and get the string. *) let close info = let { print_fd = fd; print_venv = venv; print_pos = pos; print_fmt = fmt; _ } = info in Omake_env.venv_close_channel venv pos fd; Format.pp_print_flush fmt () (* * The printers. *) let print_char info c = Lm_channel.output_char info.print_channel c let print_string info s = Lm_channel.output_string info.print_channel s (* * Formatter flushes the buffer. *) let flush info = Lm_channel.flush info.print_channel let open_box info i = flush info; Format.pp_open_box info.print_fmt i let open_hbox info = flush info; Format.pp_open_hbox info.print_fmt () let open_vbox info i = flush info; Format.pp_open_vbox info.print_fmt i let open_hvbox info i = flush info; Format.pp_open_hvbox info.print_fmt i let open_hovbox info i = flush info; Format.pp_open_hovbox info.print_fmt i let close_box info = flush info; Format.pp_close_box info.print_fmt () let print_cut info = flush info; Format.pp_close_box info.print_fmt () let print_space info = flush info; Format.pp_print_space info.print_fmt () let force_newline info = flush info; Format.pp_force_newline info.print_fmt () let print_break info i j = flush info; Format.pp_print_break info.print_fmt i j let print_flush info = flush info; Format.pp_print_flush info.print_fmt () let print_newline info = flush info; Format.pp_print_newline info.print_fmt () (* * Converters. *) let bool_of_value info v = let { print_venv = venv; print_pos = pos; _ } = info in Omake_value.bool_of_value venv pos v let char_of_value info v = let { print_venv = venv; print_pos = pos; _ } = info in let s = Omake_value.string_of_value venv pos v in if String.length s <> 1 then raise (Omake_value_type.OmakeException (pos, StringStringError ("not a character", s))); s.[0] let int_of_value info v = let { print_venv = venv; print_pos = pos; _ } = info in Omake_value.int_of_value venv pos v let float_of_value info v = let { print_venv = venv; print_pos = pos; _ } = info in Omake_value.float_of_value venv pos v let string_of_value info v = let { print_venv = venv; print_pos = pos; _ } = info in Omake_value.string_of_value venv pos v let print_value info v = flush info; Omake_value_print.pp_print_value info.print_fmt v (* * Applications. *) let apply1 info arg1 = let { print_venv = venv; print_pos = pos; print_loc = loc; print_fd = fd; _ } = info in ignore (Omake_eval.eval_apply venv pos loc arg1 [ValChannel (OutChannel, fd)] []) let apply2 info arg1 arg2 = let { print_venv = venv; print_pos = pos; print_loc = loc; print_fd = fd; _ } = info in ignore (Omake_eval.eval_apply venv pos loc arg1 [ValChannel (OutChannel, fd); arg2] []) (* * Catch too many arguments. *) let exit info args = match args with [] -> Omake_value_type.ValNone | arg :: _ -> let { print_pos = pos; _ } = info in raise (Omake_value_type.OmakeException (pos, StringValueError ("too many arguments to printf", arg))) end module Printf = Omake_printf.MakePrintf (Args);; let fprintf_aux venv pos loc channel fmt args = let fmt = Omake_value.string_of_value venv pos fmt in let buf = Args.create_channel venv pos loc channel in let result = try Printf.fprintf buf fmt args with exn -> Args.close buf; raise exn in Args.close buf; result let printf_fun venv pos loc args = let pos = string_pos "printf" pos in match args with fmt :: args -> let stdout = Omake_env.venv_find_var venv pos loc Omake_var.stdout_var in let stdout = Omake_value.channel_of_value venv pos stdout in fprintf_aux venv pos loc stdout fmt args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let eprintf_fun venv pos loc args = let pos = string_pos "eprintf" pos in match args with fmt :: args -> let stderr = Omake_env.venv_find_var venv pos loc Omake_var.stderr_var in let stderr = Omake_value.channel_of_value venv pos stderr in fprintf_aux venv pos loc stderr fmt args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let fprintf_fun venv pos loc args = let pos = string_pos "fprintf" pos in match args with fd :: fmt :: args -> let channel = Omake_value.channel_of_value venv pos fd in fprintf_aux venv pos loc channel fmt args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let sprintf_fun venv pos loc args = let pos = string_pos "sprintf" pos in match args with |fmt :: args -> let fmt = Omake_value.string_of_value venv pos fmt in let buf = Buffer.create 100 in let info = Args.create_buffer venv pos loc buf in let _ = try Printf.fprintf info fmt args with exn -> Args.close info; raise exn in Args.close info; Omake_value_type.ValData (Buffer.contents buf) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \subsection{Miscellaneous functions} * \subsubsection{set-channel-line} * * \begin{verbatim} * set-channel-line(channel, filename, line) * channel : Channel * filename : File * line : int * \end{verbatim} * * Set the line number information for the channel. * \end{doc} *) let set_channel_line_fun venv pos loc args = let pos = string_pos "set-channel-line" pos in let chan, file, line = match args with [chan; file; line] -> chan, file, line | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 3, List.length args))) in let chan = Omake_value.channel_of_value venv pos chan in let file = Omake_value.string_of_value venv pos file in let line = Omake_value.int_of_value venv pos line in Lm_channel.set_line chan file line; Omake_value_type.ValNone (************************************************************************ * Tables. *) let () = let builtin_vars = ["nl", (fun _ -> Omake_value_type.ValString "\n"); "stdin", (fun _ -> ValChannel (InChannel, Omake_env.venv_stdin)); "stdout", (fun _ -> ValChannel (OutChannel, Omake_env.venv_stdout)); "stderr", (fun _ -> ValChannel (OutChannel, Omake_env.venv_stderr))] in let builtin_funs = [true, "open-in-string", open_in_string, Omake_ir.ArityExact 1; true, "open-out-string", open_out_string, ArityExact 0; true, "out-contents", out_contents, ArityExact 1; true, "fopen", fopen, ArityExact 2; true, "close", close, ArityExact 1; true, "read", read, ArityExact 2; true, "input-line", input_line, ArityExact 1; true, "write", write, ArityRange (2, 4); true, "lseek", lseek, ArityExact 3; true, "rewind", rewind, ArityExact 1; true, "tell", tell, ArityExact 1; true, "flush", flush, ArityExact 1; true, "channel-name", channel_name, ArityExact 1; true, "dup", dup, ArityExact 1; true, "dup2", dup2, ArityExact 2; true, "set-nonblock-mode", set_nonblock_mode, ArityExact 2; true, "set-close-on-exec", set_close_on_exec_mode, ArityExact 2; true, "pipe", pipe, ArityExact 0; true, "mkfifo", mkfifo, ArityExact 2; true, "select", select, ArityExact 4; true, "lockf", lockf, ArityExact 3; true, "socket", socket, ArityExact 3; true, "bind", bind, ArityRange (2, 3); true, "listen", listen, ArityExact 2; true, "accept", accept, ArityExact 1; true, "connect", connect, ArityExact 1; true, "getc", getc, ArityRange (0, 1); true, "gets", gets, ArityRange (0, 1); true, "fgets", fgets, ArityRange (0, 1); true, "print", print, ArityExact 1; true, "eprint", eprint, ArityExact 1; true, "fprint", fprint, ArityExact 2; true, "println", println, ArityExact 1; true, "eprintln", eprintln, ArityExact 1; true, "fprintln", fprintln, ArityExact 2; true, "printv", printv, ArityExact 1; true, "eprintv", eprintv, ArityExact 1; true, "fprintv", fprintv, ArityExact 2; true, "printvln", printvln, ArityExact 1; true, "eprintvln", eprintvln, ArityExact 1; true, "fprintvln", fprintvln, ArityExact 2; true, "printf", printf_fun, ArityAny; true, "eprintf", eprintf_fun, ArityAny; true, "fprintf", fprintf_fun, ArityAny; true, "sprintf", sprintf_fun, ArityAny; true, "set-channel-line", set_channel_line_fun, ArityExact 3] in let builtin_info = {Omake_builtin_type. builtin_empty with builtin_vars = builtin_vars; builtin_funs = builtin_funs } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_printf.ml0000644000175000017500000003516713177364666016617 0ustar gerdgerd(* * This is a generic printf builder. We take "simple" printing * functions, and turn them into a general printf. * * Formatted printing. * Here are the format strings we handle. * d or i: print an integer in decminal * u: print an unsigned integer in decimal * x: print an integer in unsigned hex in lowercase * X: print an integer in unsigned hex in uppercase * o: print an integer in unsigned octal * s: print a string * c: print a character * f: print a float in decimal * e,E: print a float in exponent notation * g,G: print a float in best notation * b: print a Boolean * a: user-defined printer * t: user-defined printer * v: value printer * %: print the '%' char * * From the printf man page, each format specifier has * 1. 0 or more flags * #: use alternate notation * 0: 0-pad the number * '-': left-justify the field * ' ': leave a space before the number * '+': always print the sign of the number * 2. An optional field width in decimal * 3. An optional precision, specified as a '.' followed * by a decimal number. * 4. A format specifier * * For Format: * @]: close_box * @,: print_cut * @ : print_space * @\n: force_newline * @;: print_break * @?: print_flush * @.: print_newline * @: print_length * @@: plain @ char *) (* * Argument module. *) module type PrintfArgsSig = sig (* Some buffer type *) type t type value (* The printers *) val print_char : t -> char -> unit val print_string : t -> string -> unit (* Format functions *) val open_box : t -> int -> unit val open_hbox : t -> unit val open_vbox : t -> int -> unit val open_hvbox : t -> int -> unit val open_hovbox : t -> int -> unit val close_box : t -> unit val print_cut : t -> unit val print_space : t -> unit val force_newline : t -> unit val print_break : t -> int -> int -> unit val print_flush : t -> unit val print_newline : t -> unit val bool_of_value : t -> value -> bool val int_of_value : t -> value -> int val char_of_value : t -> value -> char val float_of_value : t -> value -> float val string_of_value : t -> value -> string val print_value : t -> value -> unit val apply1 : t -> value -> unit val apply2 : t -> value -> value -> unit val exit : t -> value list -> value end (* * What this module provides. *) module type PrintfSig = sig (* Some buffer type *) type t type value val fprintf : t -> string -> value list -> value end (* * Here's the actual printf module. *) module MakePrintf (Args : PrintfArgsSig) : PrintfSig with type t = Args.t with type value = Args.value = struct (************************************************************************ * TYPES ************************************************************************) type t = Args.t type value = Args.value (* * Field flags. *) type format_flag = AlternateForm | ZeroPad | LeftAdjust | LeaveBlank | AlwaysSign (* * Types of int printing. *) type int_spec = UnsignedOctal | SignedDecimal | UnsignedDecimal | UnsignedHexLowercase | UnsignedHexUppercase (* * Types of float printing. *) type float_spec = FloatNormal | FloatExp | FloatBest (* * Field specifiers. *) type field_info = { field_flags : format_flag list; field_width : int option; field_precision : int option } (************************************************************************ * BASE PRINTERS ************************************************************************) (* * Most of these basic printers just pass out the print * request to C functions. The first string is the format * string to be passed to printf. *) external ext_print_char : string -> char -> string = "ml_print_char" external ext_print_int : string -> int -> string = "ml_print_int" external ext_print_float : string -> float -> string = "ml_print_float" external ext_print_string : string -> string -> string = "ml_print_string" (* * Get the next argument. *) let next_arg = function arg :: args -> args, arg | [] -> raise (Failure "arity") (* * Base printers. *) let rec print_bool (buf : Args.t) (args : Args.value list) i len s fmt _info = let args, arg = next_arg args in let b = Args.bool_of_value buf arg in let str = ext_print_string fmt (if b then "true" else "false") in Args.print_string buf str; print_loop buf args i len s and print_char buf args i len s fmt _info = let args, arg = next_arg args in let c = Args.char_of_value buf arg in let str = ext_print_char fmt c in Args.print_string buf str; print_loop buf args i len s and print_int buf args i len s fmt _ _ = let args, arg = next_arg args in let j = Args.int_of_value buf arg in let str = ext_print_int fmt j in Args.print_string buf str; print_loop buf args i len s and print_float buf args i len s fmt _ _ = let args, arg = next_arg args in let x = Args.float_of_value buf arg in let str = ext_print_float fmt x in Args.print_string buf str; print_loop buf args i len s and print_string buf args i len s fmt _info = let args, arg = next_arg args in let str = Args.string_of_value buf arg in let str = ext_print_string fmt str in Args.print_string buf str; print_loop buf args i len s and print_value buf args i len s _fmt _ = let args, arg = next_arg args in Args.print_value buf arg; print_loop buf args i len s and print_user1 buf args i len s _fmt _ = let args, arg = next_arg args in Args.apply1 buf arg; print_loop buf args i len s and print_user2 buf args i len s _fmt _ = let args, arg1 = next_arg args in let args, arg2 = next_arg args in Args.apply2 buf arg1 arg2; print_loop buf args i len s and print_percent buf args i len s fmt _info = let str = ext_print_string fmt "%" in Args.print_string buf str; print_loop buf args i len s (* * Parse the format specification. *) and print_format buf (args : Args.value list) index len s = (* * Read off any flag characters. *) let rec parse_flags flags i = if i = len then Args.exit buf args else let c = s.[i] in match c with '#' -> parse_flags (AlternateForm :: flags) (succ i) | '0' -> parse_flags (ZeroPad :: flags) (succ i) | '-' -> parse_flags (LeftAdjust :: flags) (succ i) | ' ' -> parse_flags (LeaveBlank :: flags) (succ i) | '+' -> parse_flags (AlwaysSign :: flags) (succ i) | '1'..'9' -> parse_field_width flags 0 i | '.' -> parse_precision flags None 0 (succ i) | _ -> parse_spec flags None None i (* * Read off the field width. *) and parse_field_width flags width i = if i = len then Args.exit buf args else let c = s.[i] in match c with '0'..'9' -> parse_field_width flags (width * 10 + Char.code c - Char.code '0') (succ i) | '.' -> parse_precision flags (Some width) 0 (succ i) | _ -> parse_spec flags (Some width) None i (* * Parse the precision specifier. *) and parse_precision flags width pre i = if i = len then Args.exit buf args else let c = s.[i] in match c with '0'..'9' -> parse_precision flags width (pre * 10 + Char.code c - Char.code '0') (succ i) | _ -> parse_spec flags width (Some pre) i (* * Finally we have the format specifier. *) and parse_spec flags width pre i = if i = len then Args.exit buf args else let info = { field_flags = List.rev flags; field_width = width; field_precision = pre } in let c = s.[i] in let i = succ i in let fmt = String.sub s index (i - index) in match c with 'd' | 'i' -> print_int buf args i len s fmt info SignedDecimal | 'u' -> print_int buf args i len s fmt info UnsignedDecimal | 'x' -> print_int buf args i len s fmt info UnsignedHexLowercase | 'X' -> print_int buf args i len s fmt info UnsignedHexUppercase | 'o' -> print_int buf args i len s fmt info UnsignedOctal | 's' -> print_string buf args i len s fmt info | 'c' -> print_char buf args i len s fmt info | 'f' -> print_float buf args i len s fmt info FloatNormal | 'e' | 'E' -> print_float buf args i len s fmt info FloatExp | 'g' | 'G' -> print_float buf args i len s fmt info FloatBest | 'b' -> print_bool buf args i len s fmt info | 'a' -> print_user2 buf args i len s fmt info | 't' -> print_user1 buf args i len s fmt info | 'v' -> print_value buf args i len s fmt info | '%' -> print_percent buf args i len s fmt info | _ -> raise (Invalid_argument "parse_spec") in parse_flags [] (succ index) (************************************************************************ * FORMAT CONTROL ************************************************************************) (* * Parse the format string. *) and print_rformat buf args index len s = (* * Look for some options in format, * separated by white space. *) let scratch = Buffer.create 19 in let rec parse_options i cont = if i = len then cont i [] else let c = s.[i] in if c = '<' then parse_args [] (succ i) cont else cont i [] and parse_args options i cont = if i = len then cont i (List.rev options) else let c = s.[i] in match c with ' ' | '\t' | '\n' -> if Buffer.length scratch <> 0 then let s = Buffer.contents scratch in Buffer.clear scratch; parse_args (s :: options) (succ i) cont else parse_args options (succ i) cont | '>' -> cont (succ i) (List.rev options) | c -> Buffer.add_char scratch c; parse_args options (succ i) cont in (* * Now we should have the spec. *) let parse_spec i = if i = len then Args.exit buf args else let c = s.[i] in let i = succ i in match c with '[' -> parse_options i (fun i options -> let box, indent = match options with box :: indent :: _ -> box, int_of_string indent | [box] -> box, 0 | [] -> "b", 0 in let _ = match box with "h" -> Args.open_hbox buf | "v" -> Args.open_vbox buf indent | "hv" -> Args.open_hvbox buf indent | "hov" -> Args.open_hovbox buf indent | "b" -> Args.open_box buf indent | _ -> raise (Invalid_argument ("print_rformat: bogus box type \"" ^ String.escaped box ^ "\"")) in print_loop buf args i len s) | ']' -> Args.close_box buf; print_loop buf args i len s | ',' -> Args.print_cut buf; print_loop buf args i len s | ' ' -> Args.print_space buf; print_loop buf args i len s | '\n' -> Args.force_newline buf; print_loop buf args i len s | ';' -> parse_options i (fun i options -> let nspaces, off = match options with nspaces :: off :: _ -> int_of_string nspaces, int_of_string off | [nspaces] -> int_of_string nspaces, 0 | [] -> 0, 0 in Args.print_break buf nspaces off; print_loop buf args i len s) | '?' -> Args.print_flush buf; print_loop buf args i len s | '.' -> Args.print_newline buf; print_loop buf args i len s | c -> Args.print_char buf c; print_loop buf args i len s in parse_spec (succ index) (* * The is the main printf function. *) and print_loop buf args i len s = if i = len then Args.exit buf args else match s.[i] with '%' -> print_format buf args i len s | '@' -> print_rformat buf args i len s | c -> Args.print_char buf c; print_loop buf args (succ i) len s (* * Outermost printf function. *) let fprintf buf s args = print_loop buf args 0 (String.length s) s end omake-0.10.3/src/builtin/omake_builtin_shell.ml0000644000175000017500000002704113177364666020142 0ustar gerdgerd(* * Builtin shell operations. * * \begin{doc} * \input{omake-shell} * * \section{Basic builtin functions} * \end{doc} *) include Omake_pos.Make (struct let name = "Omake_builtin_io" end) (* * The string should be a job identifier. *) let pid_of_string pos s = try int_of_string s with Invalid_argument _ | Failure _ -> let pos = string_pos "pid_of_string" pos in raise (Omake_value_type.OmakeException (pos, StringStringError ("not a process identifier", s))) (* * Signal numbers. *) let signal_of_string s = match String.uppercase_ascii s with "-ABRT" -> Omake_shell_type.SigAbrt | "-ALRM" -> SigAlrm | "-HUP" -> SigHup | "-ILL" -> SigIll | "-INT" -> SigInt | "-KILL" -> SigKill | "-QUIT" -> SigQuit | "-SEGV" -> SigSegv | "-TERM" -> SigTerm | "-USR1" -> SigUsr1 | "-USR2" -> SigUsr2 | "-CHLD" -> SigChld | "-STOP" -> SigStop | "-TSTP" -> SigTstp | "-TTIN" -> SigTtin | "-TTOU" -> SigTtou | "-VTALRM" -> SigVTAlrm | "-PROF" -> SigProf | _ -> let len = String.length s in if len > 1 && s.[0] = '-' then SigNum (int_of_string (String.sub s 1 (len - 1))) else raise (Failure "signal_of_string") let signal_of_string pos s = try signal_of_string s with Failure _ -> let pos = string_pos "signal_of_string" pos in raise (Omake_value_type.OmakeException (pos, StringStringError ("not a signal", s))) (* * Print some text. * * \begin{doc} * \fun{echo} * * The \verb+echo+ function prints a string. * * \begin{verbatim} * $(echo ) * echo * \end{verbatim} * \end{doc} *) let echo_fun venv pos loc args = let pos = string_pos "echo" pos in let args = List.map (Omake_value.strings_of_value venv pos) args in let args = List.flatten args in let outx = Omake_value.channel_of_var venv pos loc Omake_var.stdout_var in let rec echo args = match args with [arg] -> Lm_channel.output_string outx arg | arg :: args -> Lm_channel.output_string outx arg; Lm_channel.output_char outx ' '; echo args | [] -> () in echo args; Lm_channel.output_char outx '\n'; Lm_channel.flush outx; Omake_value_type.ValNone (* * \begin{doc} * \fun{cd} * * The \verb+cd+ function changes the current directory. * * \begin{verbatim} * cd(dir) * dir : Dir * \end{verbatim} * * The \verb+cd+ function also supports a 2-argument form: * * \begin{verbatim} * $(cd dir, e) * dir : Dir * e : expression * \end{verbatim} * * In the two-argument form, expression \verb+e+ is evaluated * in the directory \verb+dir+. The current directory is not * changed otherwise. * * The behavior of the \verb+cd+ function can be changed with the * \verb+CDPATH+ variable, which specifies a search path for * directories. This is normally useful only in the \Prog{osh} * command interpreter. * * \begin{verbatim} * CDPATH : Dir Sequence * \end{verbatim} * * For example, the following will change directory to the first * directory \verb+./foo+, \verb+~/dir1/foo+, \verb+~/dir2/foo+. * * \begin{verbatim} * CDPATH[] = * . * $(HOME)/dir1 * $(HOME)/dir2 * cd foo * \end{verbatim} * * \end{doc} *) type cd_status = CdFail | CdFile | CdSuccess let dir_test name = Sys.os_type = "Win32" || (Unix.access name [Unix.X_OK]; true) let cd_test _ _ _ dir = let name = Omake_node.Dir.fullname dir in try let stat = Unix.LargeFile.stat name in if stat.Unix.LargeFile.st_kind <> Unix.S_DIR then CdFile else if dir_test name then CdSuccess else CdFail with Unix.Unix_error _ -> CdFail let cd_dir venv pos loc dir = match cd_test venv pos loc dir with CdFail -> let relname = Omake_node.Dir.name (Omake_env.venv_dir venv) dir in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("no such directory", relname))) | CdFile -> let relname = Omake_node.Dir.name (Omake_env.venv_dir venv) dir in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("not a directory", relname))) | CdSuccess -> dir let rec cd_search venv cdpath pos loc name = match cdpath with [] -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("no such directory", name))) | cd_dir :: cd_path -> let dir = Omake_node.Dir.chdir cd_dir name in match cd_test venv pos loc dir with CdFail | CdFile -> cd_search venv cd_path pos loc name | CdSuccess -> dir let cd_aux venv cd_path pos loc arg = match Omake_value.values_of_value venv pos arg with [dir] -> (match Omake_value.eval_prim_value venv pos dir with ValDir dir -> cd_dir venv pos loc dir | _ -> let name = Omake_value.string_of_value venv pos dir in if Filename.is_relative name then cd_search venv cd_path pos loc name else cd_dir venv pos loc (Omake_node.Dir.chdir Omake_node.Dir.root name)) | [] -> cd_dir venv pos loc (Omake_env.venv_intern_dir venv Omake_state.home_dir) | args -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let cd_fun venv pos loc args kargs = let pos = string_pos "cd" pos in let cd_path = try Omake_env.venv_find_var_exn venv Omake_var.cdpath_var with Not_found -> ValString "." in let cd_path = Omake_value.values_of_value venv pos cd_path in let cd_path = List.map (Omake_value.dir_of_value venv pos) cd_path in match args, kargs with [arg], [] -> let dir = cd_aux venv cd_path pos loc arg in let venv = Omake_env.venv_chdir_tmp venv dir in venv, Omake_value_type.ValDir dir | [dir; e], [] -> (* Change temporarily and evaluate the exp *) let dir = cd_aux venv cd_path pos loc dir in let venv_new = Omake_env.venv_chdir_tmp venv dir in let values = Omake_value.values_of_value venv_new pos e in venv, Omake_value.concat_array values | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (1, 2), List.length args))) (* * \begin{doc} * \section{Job control builtin functions} * \fun{jobs} * * The \verb+jobs+ function prints a list of jobs. * * \verb+jobs+ * \end{doc} *) let jobs_fun venv pos _ _ = let _pos = string_pos "jobs" pos in Omake_shell_job.jobs venv; Omake_value_type.ValNone (* * \begin{doc} * \fun{bg} * * The \verb+bg+ function places a job in the background. * * \verb+bg + * \end{doc} *) let jobs_iter_fun f venv pos loc args = let pos = string_pos "iter" pos in match args with [arg] -> let pids = Omake_value.strings_of_value venv pos arg in let pids = List.map (pid_of_string pos) pids in List.iter (f venv pos) pids | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let bg_fun venv pos loc args = let pos = string_pos "bg" pos in jobs_iter_fun Omake_shell_job.bg venv pos loc args; Omake_value_type.ValNone (* * \begin{doc} * \fun{fg} * * The \verb+fg+ function brings a job to the foreground. * * \verb+fg + * \end{doc} *) let fg_fun venv pos loc args = let pos = string_pos "fg" pos in jobs_iter_fun Omake_shell_job.fg venv pos loc args; Omake_value_type.ValNone (* * \begin{doc} * \fun{stop} * * The \verb+stop+ function suspends a job. * * \verb+stop + * \end{doc} *) let stop_fun venv pos loc args = let pos = string_pos "stop" pos in jobs_iter_fun Omake_shell_job.stop venv pos loc args; Omake_value_type.ValNone (* * \begin{doc} * \fun{wait} * * The \verb+wait+ function waits for a job to finish. * If no process identifiers are given, the shell waits for * all jobs to complete. * * \verb+wait + * \end{doc} *) let wait_fun venv pos loc args = let pos = string_pos "wait" pos in jobs_iter_fun Omake_shell_job.wait venv pos loc args; Omake_value_type.ValNone (* * \begin{doc} * \fun{kill} * * The \verb+kill+ function signals a job. * * \verb+kill [signal] + * \end{doc} *) let kill_fun venv pos loc args = let pos = string_pos "kill" pos in match args with [arg] -> let args = Omake_value.strings_of_value venv pos arg in let signal, args = match args with signal :: args' -> if String.length signal > 1 && signal.[0] = '-' then signal_of_string pos signal, args' else SigInt, args | [] -> SigInt, [] in let args = List.map (pid_of_string pos) args in List.iter (fun pid -> Omake_shell_job.kill venv pos pid signal) args; Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \section{Command history} * \fun{history} * * \begin{verbatim} * $(history-index) : Int * $(history) : String Sequence * history-file : File * history-length : Int * \end{verbatim} * * The history variables manage the command-line history in \Prog{osh}. They have no effect * in \Prog{omake}. * * The \verb+history-index+ variable is the current index into the command-line history. * The \verb+history+ variable is the current command-line history. * * The \verb+history-file+ variable can be redefined if you want the command-line history * to be saved. The default value is \verb+~/.omake/osh_history+. * * The \verb+history-length+ variable can be redefined to specify the maximum number of * lines in the history that you want saved. The default value is \verb+100+. * \end{doc} *) let history_index _ pos loc args = let pos = string_pos "history-index" pos in match args with [] -> Omake_value_type.ValInt (Lm_readline.where ()) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 0, List.length args))) let history _ pos loc args = let pos = string_pos "history" pos in match args with | [] -> let strings = Lm_readline.history () in let strings = Array.to_list strings in let strings = List.map (fun s -> Omake_value_type.ValData s) strings in Omake_value_type.ValArray strings | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 0, List.length args))) (************************************************************************ * Tables. *) let () = let builtin_vars = ["history-file", (fun _ -> Omake_value_type.ValNode (Omake_node.Node.create_node Omake_node.no_mount_info Omake_node.Mount.empty (Omake_node.Dir.cwd ()) (Omake_state.history_file ()))); "history-length", (fun _ -> ValInt 100); "CDPATH", (fun _ -> ValArray [ValString "."])] in let builtin_funs = [true, "echo", echo_fun, Omake_ir.ArityAny; true, "jobs", jobs_fun, ArityExact 1; true, "bg", bg_fun, ArityExact 1; true, "fg", fg_fun, ArityExact 1; true, "stop", stop_fun, ArityExact 1; true, "wait", wait_fun, ArityExact 1; true, "kill", kill_fun, ArityExact 1; true, "history-index", history_index, ArityExact 0; true, "history", history, ArityExact 0; ] in let builtin_kfuns = [false, "cd", cd_fun, Omake_ir.ArityRange (1, 2); ] in let builtin_info = { Omake_builtin_type.builtin_empty with builtin_vars = builtin_vars; builtin_funs = builtin_funs; builtin_kfuns = builtin_kfuns } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_builtin_arith.ml0000644000175000017500000002051513177364666020141 0ustar gerdgerd(* * \begin{doc} * \section{Arithmetic} * \end{doc} *) include Omake_pos.Make (struct let name = "Omake_builtin_arith" end) (* * \begin{doc} * \fun{int} * * The \verb+int+ function can be used to create integers. * It returns an \verb+Int+ object. * * \verb+$(int 17)+. * * \fun{float} * The \verb+float+ function can be used to create floating-point numbers. * It returns a \verb+Float+ object. * * \verb+$(float 3.1415926)+. * \end{doc} *) let int_fun venv pos loc args = let pos = string_pos "int" pos in match args with [arg] -> let values = Omake_value.values_of_value venv pos arg in let values = List.map (fun v -> Omake_value_type.ValInt (Omake_value.int_of_value venv pos v)) values in Omake_value.concat_array values | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let float_fun venv pos loc args = let pos = string_pos "int" pos in match args with | [arg] -> let values = Omake_value.values_of_value venv pos arg in let values = List.map (fun v -> Omake_value_type.ValFloat (Omake_value.float_of_value venv pos v)) values in Omake_value.concat_array values | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Basic arithmetic. * * \begin{doc} * \subsection{Basic arithmetic} * \funref{neg} * \funref{add} * \funref{sub} * \funref{mul} * \funref{div} * \funref{mod} * \funref{lnot} * \funref{land} * \funref{lor} * \funref{lxor} * \funref{lsl} * \funref{lsr} * \funref{asr} * \funref{min} * \funref{max} * * The following functions can be used to perform basic arithmetic. * * \begin{itemize} * \item \verb+$(neg )+: arithmetic inverse * \item \verb+$(add )+: addition. * \item \verb+$(sub )+: subtraction. * \item \verb+$(mul )+: multiplication. * \item \verb+$(div )+: division. * \item \verb+$(mod )+: remainder. * \item \verb+$(lnot )+: bitwise inverse. * \item \verb+$(land )+: bitwise and. * \item \verb+$(lor )+: bitwise or. * \item \verb+$(lxor )+: bitwise exclusive-or. * \item \verb+$(lsl )+: logical shift left. * \item \verb+$(lsr )+: logical shift right. * \item \verb+$(asr )+: arithmetic shift right. * \item \verb+$(min )+: smallest element. * \item \verb+$(max )+: largest element. * \end{itemize} * \end{doc} *) let unary_int op_int venv pos loc args = let pos = string_pos "unary_int" pos in match args with | [arg] -> Omake_value.concat_array (List.map (fun _ -> Omake_value_type.ValInt (op_int (Omake_value.int_of_value venv pos arg))) (Omake_value.values_of_value venv pos arg)) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let arith_int id_int op_int venv pos _ args = let pos = string_pos "arith_int" pos in let collect i arg = op_int i (Omake_value.int_of_value venv pos arg) in let args = match args with | [arg] -> Omake_value.values_of_value venv pos arg | _ -> args in match args with | arg :: args -> Omake_value_type.ValInt (List.fold_left collect (Omake_value.int_of_value venv pos arg) args) | [] -> ValInt id_int let unary op_int op_float venv pos loc args = let pos = string_pos "unary" pos in match args with | [arg] -> Omake_value.concat_array (List.map (fun v -> match Omake_value.number_of_value venv pos v with |Omake_value_type.ValInt i -> Omake_value_type.ValInt (op_int i) | ValFloat x -> ValFloat (op_float x) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError "not a number"))) (**) (Omake_value.values_of_value venv pos arg)) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let arith id_int op_int op_float venv pos loc args = let pos = string_pos "arith" pos in let collect (i : Omake_value_type.t) arg : Omake_value_type.t = match i, Omake_value.number_of_value venv pos arg with | ValInt i, ValInt arg -> ValInt (op_int i arg) | ValInt i, ValFloat arg -> ValFloat (op_float (float_of_int i) arg) | ValFloat i, ValInt arg -> ValFloat (op_float i (float_of_int arg)) | ValFloat i, ValFloat arg -> ValFloat (op_float i arg) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError "not a number")) in let args = match args with [arg] -> Omake_value.values_of_value venv pos arg | _ -> args in match args with | arg :: args -> List.fold_left collect (Omake_value.number_of_value venv pos arg) args | [] -> ValInt id_int (* * Basic arithmetic. * * \begin{doc} * \subsection{Comparisons} * \funref{lt} * \funref{le} * \funref{eq} * \funref{ge} * \funref{gt} * \funref{ult} * \funref{ule} * \funref{uge} * \funref{ugt} * * The following functions can be used to perform numerical comparisons. * * \begin{itemize} * \item \verb+$(lt )+: less then. * \item \verb+$(le )+: no more than. * \item \verb+$(eq )+: equal. * \item \verb+$(ge )+: no less than. * \item \verb+$(gt )+: greater than. * \item \verb+$(ult )+: unsigned less than. * \item \verb+$(ule )+: unsigned greater than. * \item \verb+$(uge )+: unsigned greater than or equal. * \item \verb+$(ugt )+: unsigned greater than. * \end{itemize} * \end{doc} *) let compare op_int op_float venv pos loc args = let pos = string_pos "arith" pos in let rec collect (i : Omake_value_type.t) args = match args with | arg :: args -> let arg = Omake_value.number_of_value venv pos arg in let test = match i, Omake_value.number_of_value venv pos arg with | ValInt i, ValInt arg -> op_int i arg | ValInt i, ValFloat arg -> op_float (float_of_int i) arg | ValFloat i, ValInt arg -> op_float i (float_of_int arg) | ValFloat i, ValFloat arg -> op_float i arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError "not a number")) in test && collect arg args | [] -> true in match args with | arg :: args -> Omake_builtin_util.val_of_bool (collect (Omake_value.number_of_value venv pos arg) args) | [] -> Omake_builtin_util.val_true (************************************************************************ * Tables. *) let () = let builtin_funs = [true, "int", int_fun, Omake_ir.ArityExact 1; true, "float", float_fun, ArityExact 1; true, "neg", unary (~-) (~-.), ArityExact 1; true, "add", arith 0 ( + ) ( +. ), ArityAny; true, "sub", arith 0 ( - ) ( -. ), ArityAny; true, "mul", arith 1 ( * ) ( *. ), ArityAny; true, "div", arith 1 ( / ) ( /. ), ArityAny; true, "mod", arith 1 (mod) (mod_float), ArityAny; true, "min", arith max_int min min, ArityAny; true, "max", arith min_int max max, ArityAny; true, "mod", arith 1 (mod) (mod_float), ArityAny; true, "lnot", unary_int (lnot), ArityExact 1; true, "land", arith_int 0 (land), ArityAny; true, "lor", arith_int 0 (lor) , ArityAny; true, "lxor", arith_int 0 (lxor), ArityAny; true, "lsl", arith_int 0 (lsl), ArityAny; true, "lsr", arith_int 0 (lsr), ArityAny; true, "asr", arith_int 0 (asr), ArityAny; true, "lt", compare (<) (<), ArityAny; true, "le", compare (<=) (<=), ArityAny; true, "eq", compare (=) (=), ArityAny; true, "ge", compare (>=) (>=), ArityAny; true, "gt", compare (>) (>), ArityAny] in let builtin_info = { Omake_builtin_type.builtin_empty with builtin_funs = builtin_funs } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_builtin_file.ml0000644000175000017500000030041613177364666017752 0ustar gerdgerd(* * Builtin operations on files. * * \begin{doc} * \chapter{File, I/O and system operations} * \label{chapter:system} * \cutname{omake-system.html} * \end{doc} * *) include Omake_pos.Make (struct let name = "Omake_builtin_file" end) (* * Utilities. *) let is_dir dir = try Sys.is_directory dir with Sys_error _ -> false let is_dir_no_symlink dir = try let st = Unix.lstat dir in Unix.(st.st_kind = S_DIR) with | Unix.Unix_error _ -> false (* * Get the file from a string. * * \begin{doc} * \section{File names} * \twofuns{file}{dir} * * \begin{verbatim} * $(file sequence) : File Sequence * sequence : Sequence * $(dir sequence) : Dir Sequence * sequence : Sequence * \end{verbatim} * * The \verb+file+ and \verb+dir+ functions define location-independent references to files and directories. * In \Prog{omake}, the commands to build a target are executed in the target's directory. Since there may be * many directories in an \Prog{omake} project, the build system provides a way to construct a reference to a file * in one directory, and use it in another without explicitly modifying the file name. The functions have the following * syntax, where the name should refer to a file or directory. * * For example, we can construct a reference to a file \verb+foo+ in the current directory. * * \begin{verbatim} * FOO = $(file foo) * .SUBDIRS: bar * \end{verbatim} * * If the \verb+FOO+ variable is expanded in the \verb+bar+ subdirectory, it will expand to \verb+../foo+. * * These commands are often used in the top-level OMakefile to provide location-independent references to * top-level directories, so that build commands may refer to these directories as if they were absolute. * * \begin{verbatim} * ROOT = $(dir .) * LIB = $(dir lib) * BIN = $(dir bin) * \end{verbatim} * * Once these variables are defined, they can be used in build commands in subdirectories as follows, where * \verb+$(BIN)+ will expand to the location of the \verb+bin+ directory relative to the command being executed. * * \begin{verbatim} * install: hello * cp hello $(BIN) * \end{verbatim} * \end{doc} *) let file venv pos loc args = let pos = string_pos "file" pos in match args with [arg] -> let values = Omake_value.values_of_value venv pos arg in let values = List.map (Omake_value.node_value_of_value venv pos) values in Omake_value.concat_array values | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let dir venv pos loc args = let pos = string_pos "dir" pos in match args with [arg] -> let values = Omake_value.values_of_value venv pos arg in let values = List.map (Omake_value.dir_value_of_value venv pos) values in Omake_value.concat_array values | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{tmpfile} * * \begin{verbatim} * $(tmpfile prefix) : File * $(tmpfile prefix, suffix) : File * prefix : String * suffix : String * \end{verbatim} * * The \verb+tmpfile+ function returns the name of a fresh temporary file in * the temporary directory. * \end{doc} *) let tmpfile venv pos loc args : Omake_value_type.t = let pos = string_pos "tmpfile" pos in let prefix, suffix = match args with | [prefix] -> Omake_value.string_of_value venv pos prefix, ".omake" | [prefix; suffix] -> Omake_value.string_of_value venv pos prefix, Omake_value.string_of_value venv pos suffix | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (1, 2), List.length args))) in ValNode (Omake_env.venv_intern venv PhonyProhibited (Filename.temp_file prefix suffix)) (* * Display something from a different directory. * * \begin{doc} * \fun{in} * * \begin{verbatim} * $(in dir, exp) : String Array * dir : Dir * exp : expression * \end{verbatim} * * The \verb+in+ function is closely related to the \verb+dir+ and * \verb+file+ functions. It takes a directory and an expression, and * evaluates the expression in that effective directory. * For example, one common way to install a file is to define a symbol link, where the * value of the link is relative to the directory where the link is created. * * The following commands create links in the \verb+$(LIB)+ directory. * * \begin{verbatim} * FOO = $(file foo) * install: * ln -s $(in $(LIB), $(FOO)) $(LIB)/foo * \end{verbatim} * * Note that the \verb+in+ function only affects the expansion of \verb+Node+ * (\verb+File+ and \verb+Dir+) values. * \end{doc} *) let ind venv pos loc args = let pos = string_pos "ind" pos in match args with | [dir; arg] -> (* * BUG: JYH: evaluate the arguments early, so that commands * like the following work. * * %.out: %.in * echo $(in foo, $(file $<)) * * Without this eager evaluation, this command wouldn't * work because expressions in rules bodies are evaluated * lazily, and the $(file $<) needs to be evaluated early. *) let arg = Omake_value.concat_array (Omake_value.values_of_value venv pos arg) in let dir = Omake_value.dir_of_value venv pos dir in let venv = Omake_env.venv_chdir_tmp venv dir in let strings = Omake_value.strings_of_value venv pos arg in Omake_value.concat_strings strings | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Strip the directory. * * \begin{doc} * \fun{basename} * * \begin{verbatim} * $(basename files) : String Sequence * files : String Sequence * \end{verbatim} * * The \verb+basename+ function returns the base names for a list of files. * The basename is the filename with any leading directory components removed. * * For example, the expression \verb+$(basename dir1/dir2/a.out /etc/modules.conf /foo.ml)+ evaluates to * \verb+a.out modules.conf foo.ml+. * \end{doc} *) let basename venv pos loc args = let pos = string_pos "basename" pos in match args with [arg] -> let args = Omake_value.strings_of_value venv pos arg in let args = List.map Filename.basename args in Omake_value.concat_strings args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Strip the directory. * * \begin{doc} * \fun{dirname} * * \begin{verbatim} * $(dirname files) : String Sequence * files : String Sequence * \end{verbatim} * * The \verb+dirname+ function returns the directory name for a list of files. * The directory name is the filename with the basename removed. If a name * does not have a directory part, the directory is ``.'' * * For example, the expression \verb+$(dirname dir1\dir2\a.out /etc/modules.conf /foo.ml bar.ml)+ evaluates to * \verb+dir1/dir2 /etc / .+. * * \textbf{Note}: this function is different from the \verb+dirof+ function. * The function \verb+dirname+ is simple a function over strings, while * \verb+dirof+ is a function on filenames. * \end{doc} *) let dirname venv pos loc args = let pos = string_pos "dirname" pos in match args with [arg] -> let args = Omake_value.strings_of_value venv pos arg in let args = List.map Filename.dirname args in Omake_value.concat_strings args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Strip the directory. * * \begin{doc} * \fun{rootname} * * \begin{verbatim} * $(rootname files) : String Sequence * files : String Sequence * \end{verbatim} * * The \verb+rootname+ function returns the root name for a list of files. * The rootname is the filename with the final suffix removed. * * For example, the expression \verb+$(rootname dir1/dir2/a.out /etc/a.b.c /foo.ml)+ evaluates to * \verb+dir1/dir2/a /etc/a.b /foo+. * \end{doc} *) let rootname venv pos loc args = let pos = string_pos "rootname" pos in match args with [arg] -> let args = Omake_value.strings_of_value venv pos arg in let args = List.map Lm_filename_util.root args in Omake_value.concat_strings args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Get the directory. * * \begin{doc} * \fun{dirof} * * \begin{verbatim} * $(dirof files) : Dir Sequence * files : File Sequence * \end{verbatim} * * The \verb+dirof+ function returns the directory for each of the listed files. * * For example, the expression \verb+$(dirof dir/dir2/a.out /etc/modules.conf /foo.ml)+ evaluates * to the directories \verb+dir1/dir2 /etc /+. * \end{doc} *) let dirof venv pos loc args : Omake_value_type.t = let pos = string_pos "dirof" pos in match args with [arg] -> let values = Omake_value.values_of_value venv pos arg in let dirs = List.map (fun v -> let v = Omake_value.node_value_of_value venv pos v in match v with | ValNode node -> Omake_value_type.ValDir (Omake_node.Node.dir node) | ValDir _ -> v | _ -> raise (Invalid_argument "dirof")) values in Omake_value.concat_array dirs | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{fullname} * * \begin{verbatim} * $(fullname files) : String Sequence * files : File Sequence * \end{verbatim} * * The \verb+fullname+ function returns the pathname relative to the project root * for each of the files or directories. * \end{doc} *) let fullname venv pos loc args = let pos = string_pos "fullname" pos in match args with [arg] -> let values = Omake_value.values_of_value venv pos arg in let strings = List.map (fun v -> let s = match Omake_value.node_value_of_value venv pos v with | ValDir dir -> Omake_node.Dir.fullname dir | ValNode node -> Omake_node.Node.fullname node | v -> raise (Omake_value_type.OmakeFatalErr (loc_pos loc pos, StringValueError ("not a file", v))) in Omake_value_type.ValString s) values in Omake_value.concat_array strings | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{absname} * * \begin{verbatim} * $(absname files) : String Sequence * files : File Sequence * \end{verbatim} * * The \verb+absname+ function returns the absolute pathname for each of the files * or directories. * \end{doc} *) let absname venv pos loc args = let pos = string_pos "absname" pos in match args with | [arg] -> let values = Omake_value.values_of_value venv pos arg in let strings = List.map (fun v -> let s = match Omake_value.node_value_of_value venv pos v with | ValDir dir -> Omake_node.Dir.absname dir | ValNode node -> Omake_node.Node.absname node | v -> raise (Omake_value_type.OmakeFatalErr (loc_pos loc pos, StringValueError ("not a file", v))) in Omake_value_type.ValString s) values in Omake_value.concat_array strings | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Strip the directory. * * \begin{doc} * \fun{homename} * * \begin{verbatim} * $(homename files) : String Sequence * files : File Sequence * \end{verbatim} * * The \verb+homename+ function returns the name of a file in * tilde form, if possible. The unexpanded forms are computed * lazily: the \verb+homename+ function will usually evaluate to an absolute * pathname until the first tilde-expansion for the same directory. * \end{doc} *) let homename venv pos loc args = let pos = string_pos "rootname" pos in match args with | [arg] -> let args = Omake_value.values_of_value venv pos arg in let args = List.map (Omake_value.node_value_of_value venv pos) args in let venv = Omake_env.venv_chdir_tmp venv Omake_node.Dir.root in let args = List.map (fun v -> Omake_value_type.ValString (Lm_glob.tilde_collapse (Omake_value.string_of_value venv pos v))) args in Omake_value.concat_array args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Strip the directory. * * \begin{doc} * \fun{suffix} * * \begin{verbatim} * $(suffix files) : String Sequence * files : StringSequence * \end{verbatim} * * The \verb+suffix+ function returns the suffixes for a list of files. * If a file has no suffix, the function returns the empty string. * * For example, the expression \verb+$(suffix dir1/dir2/a.out /etc/a /foo.ml)+ evaluates * to \verb+.out .ml+. * \end{doc} *) let suffix venv pos loc args = let pos = string_pos "suffix" pos in match args with [arg] -> let args = Omake_value.strings_of_value venv pos arg in let args = List.map Lm_filename_util.suffix args in Omake_value.concat_strings args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Search the PATH. * * \begin{doc} * \section{Path search} * \fun{which} * * \begin{verbatim} * $(which files) : File Sequence * files : String Sequence * \end{verbatim} * * The \verb+which+ function searches for executables in the * current command search path, and returns \verb+file+ values * for each of the commands. It is an error if a command is * not found. * \end{doc} *) let which venv pos loc args = let pos = string_pos "which" pos in match args with |[arg] -> let path = Omake_env.venv_find_var venv pos loc Omake_var.path_var in let path = Omake_eval.path_of_values venv pos (Omake_value.values_of_value venv pos path) "." in let cache = Omake_env.venv_cache venv in let path = Omake_cache.ls_exe_path cache path in let args = Omake_value.strings_of_value venv pos arg in let args = List.map (fun s -> try Omake_value_type.ValNode (Omake_cache.exe_find cache path s) with Not_found -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("command not found", s)))) args in Omake_value.concat_array args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{where} * * The \verb+where+ function is similar to which, except it returns the list of * all the locations of the given executable (in the order in which the * corresponding directories appear in \verb+$PATH+). In case a command is handled * internally by the \verb+Shell+ object, the first string in the output will * describe the command as a built-in function. * * \begin{verbatim} * % where echo * echo is a Shell object method (a built-in function) * /bin/echo * \end{verbatim} * \end{doc} *) let where venv pos loc args = let pos = string_pos "where" pos in match args with | [arg] -> begin match Omake_value.strings_of_value venv pos arg with [arg] -> let path = Omake_env.venv_find_var venv pos loc Omake_var.path_var in let path = Omake_eval.path_of_values venv pos (Omake_value.values_of_value venv pos path) "." in let cache = Omake_env.venv_cache venv in let path = Omake_cache.ls_exe_path cache path in let res = Omake_cache.exe_find_all cache path arg in let res = List.map (fun v -> Omake_value_type.ValNode v) res in let res = try let obj = Omake_env.venv_find_var_exn venv Omake_var.shell_object_var in match Omake_value.eval_single_value venv pos obj with | ValObject obj -> let v = Omake_env.venv_find_field_internal_exn obj (Lm_symbol.add arg) in let kind = match Omake_value.eval_value venv pos v with | ValPrim _ -> "Shell object method (a built-in function)" | ValFun _ -> "Shell object method (an omake function)" | _ -> "Shell object method" in Omake_value_type.ValData (arg ^ " is a " ^ kind) :: res | _ -> res with Not_found -> res in Omake_value.concat_array res | args -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) end | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{rehash} * * \begin{verbatim} * rehash() * \end{verbatim} * * The \verb+rehash+ function resets all search paths. * \end{doc} *) let rehash venv _ _ _ = let cache = Omake_env.venv_cache venv in Omake_cache.rehash cache; Omake_value_type.ValNone (* * \begin{doc} * \fun{exists-in-path} * * \begin{verbatim} * $(exists-in-path files) : String * files : String Sequence * \end{verbatim} * * The \verb+exists-in-path+ function tests whether all executables * are present in the current search path. * \end{doc} *) let exists_in_path venv pos loc args = let pos = string_pos "exists-in-path" pos in match args with [arg] -> let args = Omake_value.strings_of_value venv pos arg in let test = List.for_all (fun s -> try ignore (Lm_filename_util.which s); true with Failure _ | Not_found -> false) args in Omake_builtin_util.val_of_bool test | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \threefuns{digest}{digest-optional}{digest-string} * * \begin{verbatim} * $(digest files) : String Array * file : File Array * raises RuntimeException * * $(digest-optional files) : String Array * file : File Array * * $(digest-string s) : String * s : String * \end{verbatim} * * The \verb+digest+ and \verb+digest-optional+ functions compute MD5 digests * of files. The \verb+digest+ function raises an exception if a file * does no exist. The \verb+digest-optional+ returns \verb+false+ if a * file does no exist. MD5 digests are cached. * \end{doc} *) let digest_aux fail venv pos loc args = let pos = string_pos "digest" pos in match args with [arg] -> let cache = Omake_env.venv_cache venv in let values = Omake_value.values_of_value venv pos arg in let values = List.map (fun v -> match Omake_value.node_value_of_value venv pos v with ValNode node -> (match Omake_cache.stat cache node with Some (_,digest) -> Omake_value_type.ValData (Lm_string_util.hexify digest) | None -> if fail then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringNodeError ("file does not exist", node))) else Omake_builtin_util.val_false) | _ -> if fail then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringValueError ("not a file", v))) else Omake_builtin_util.val_false) values in Omake_value.concat_array values | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let digest = digest_aux true let digest_optional = digest_aux false (* * A simple string. *) let digest_string venv pos _ args = let pos = string_pos "digest_string" pos in let s = match args with | [arg] -> Omake_value.string_of_value venv pos arg | _ -> raise (Omake_value_type.OmakeException (pos, ArityMismatch (ArityExact 1, List.length args))) in Omake_value_type.ValData (Digest.string s) (* * \begin{doc} * \twofuns{find-in-path}{find-in-path-optional} * * \begin{verbatim} * $(find-in-path path, files) : File Array * path : Dir Array * files : String Array * raises RuntimeException * * $(find-in-path-optional path, files) : File Array * \end{verbatim} * * The \verb+find-in-path+ function searches for the files in a search * path. Only the tail of the filename is significant. The \verb+find-in-path+ * function raises an exception if the file can't be found. * The \verb+find-in-path-optional+ function silently removes * files that can't be found. * \end{doc} *) let search_path_aux fail venv pos loc args = let pos = string_pos "search-path" pos in match args with | [dirs; arg] -> (* List the path *) let cache = Omake_env.venv_cache venv in let path = Omake_value.values_of_value venv pos dirs in let path = Omake_eval.path_of_values venv pos path "." in let listing = Omake_cache.ls_path cache path in (* Find each file *) let files = Omake_value.strings_of_value venv pos arg in let files = List.fold_left (fun files s -> let s = Filename.basename s in try let file = match Omake_cache.listing_find cache listing s with | DirEntry dir -> Omake_value_type.ValDir dir | NodeEntry node -> ValNode node in file :: files with Not_found -> if fail then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("file not found", s))) else files) [] files in Omake_value.concat_array (List.rev files) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let find_in_path = search_path_aux true let find_in_path_optional = search_path_aux false (* * \begin{doc} * \twofuns{digest-in-path}{digest-in-path-optional} * * \begin{verbatim} * $(digest-in-path path, files) : String/File Array * path : Dir Array * files : String Array * raises RuntimeException * * $(digest-in-path-optional path, files) : String/File Array * \end{verbatim} * * The \verb+digest-in-path+ function searches for the files in a search * path and returns the file and digest for each file. Only the tail of the * filename is significant. The \verb+digest-in-path+ function raises an exception * if the file can't be found. The \verb+digest-in-path-optional+ * function silently removes elements that can't be found. * \end{doc} *) let digest_path_aux fail venv pos loc args = let pos = string_pos "digest-path" pos in match args with | [dirs; arg] -> (* List the path *) let cache = Omake_env.venv_cache venv in let path = Omake_value.values_of_value venv pos dirs in let path = Omake_eval.path_of_values venv pos path "." in let listing = Omake_cache.ls_path cache path in (* Find each file *) let files = Omake_value.strings_of_value venv pos arg in let files = List.fold_left (fun files s -> let s = Filename.basename s in try let file = match Omake_cache.listing_find cache listing s with | DirEntry dir -> Omake_value_type.ValArray [ValDir dir; ValData "directory"] | NodeEntry node -> match Omake_cache.stat cache node with Some(_,digest) -> ValArray [ValNode node; ValData (Lm_string_util.hexify digest)] | None -> raise Not_found in file :: files with Not_found -> if fail then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("file not found", s))) else files) [] files in Omake_value.concat_array (List.rev files) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let digest_in_path = digest_path_aux true let digest_in_path_optional = digest_path_aux false (* * Check if a file exists. * * \begin{doc} * \section{File stats} * \threefuns{file-exists}{target-exists}{target-is-proper} * * \begin{verbatim} * $(file-exists files) : String * $(target-exists files) : String * $(target-is-proper files) : String * files : File Sequence * \end{verbatim} * * The \verb+file-exists+ function checks whether the files listed exist. * The \verb+target-exists+ function is similar to the \verb+file-exists+ function. * However, it returns true if the file exists \emph{or} if it can be built * by the current project. The \verb+target-is-proper+ returns true only * if the file can be generated in the current project. * \end{doc} *) let node_exists node_exists venv pos loc args = let pos = string_pos "file-exists" pos in match args with [arg] -> let cache = Omake_env.venv_cache venv in let args = Omake_value.values_of_value venv pos arg in let b = List.for_all (fun arg -> node_exists cache venv pos (Omake_value.file_of_value venv pos arg)) args in Omake_builtin_util.val_of_bool b | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{stat-reset} * * \begin{verbatim} * $(stat-reset files) : String * files : File Sequence * \end{verbatim} * * \OMake{} uses a stat-cache. The \verb+stat-reset+ function reset the \verb+stat+ * information for the given files, forcing the \verb+stat+ information to * be recomputed the next time it is requested. * \end{doc} *) let stat_reset venv pos loc args = let pos = string_pos "stat-reset" pos in match args with | [arg] -> let cache = Omake_env.venv_cache venv in let args = Omake_value.values_of_value venv pos arg in List.iter (fun arg -> Omake_cache.reset cache (Omake_value.file_of_value venv pos arg)) args; Omake_value_type.ValSequence [] | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Filter out the files that don't exist. * * \begin{doc} * \threefuns{filter-exists}{filter-targets}{filter-proper-targets} * * \begin{verbatim} * $(filter-exists files) : File Sequence * $(filter-targets files) : File Sequence * $(filter-proper-targets) : File Sequence * files : File Sequence * \end{verbatim} * * The \verb+filter-exists+, \verb+filter-targets+, and \verb+filter-proper-targets+ * functions remove files from a list of files. * \begin{itemize} * \item \verb+filter-exists+: the result is the list of files that exist. * \item \verb+filter-targets+: the result is the list of files either exist, or * can be built by the current project. * \item \verb+filter-proper-targets+: the result is the list of files that can * be built in the current project. * \end{itemize} * * \paragraph{Creating a ``distclean'' target} * \label{section:distclean} * * One way to create a simple ``\verb+distclean+'' rule that removes generated files from * the project is by removing all files that can be built in the current * project. * * \textbf{CAUTION:} you should be careful before you do this. The rule * removes \emph{any} file that can \emph{potentially} be reconstructed. * There is no check to make sure that the commands to rebuild the file * would actually succeed. Also, note that no file outside the * current project will be deleted. * * \begin{verbatim} * .PHONY: distclean * * distclean: * rm $(filter-proper-targets $(ls R, .)) * \end{verbatim} * * If you use CVS, you may wish to utilize the \verb+cvs_realclean+ program that * is distributed with \OMake{} in order to create a ``\verb+distclean+'' rule that would * delete all the files thare are not known to CVS. For example, if you already have a more traditional * ``\verb+clean+'' target defined in your project, and if you want the ``\verb+distclean+'' rule to * be interactive by default, you can write the following: * * \begin{verbatim} * if $(not $(defined FORCE_REALCLEAN)) * FORCE_REALCLEAN = false * export * * distclean: clean * cvs_realclean $(if $(FORCE_REALCLEAN), -f) -i .omakedb -i .omakedb.lock * \end{verbatim} * * You can add more files that you want to always keep (such as configuration files) with the -i option. * * Similarly, if you use Subversion, you utilize the \verb+build/svn_realclean.om+ script that comes with \OMake: * * \begin{verbatim} * if $(not $(defined FORCE_REALCLEAN)) * FORCE_REALCLEAN = false * export * * open build/svn_realclean * * distclean: clean * svn_realclean $(if $(FORCE_REALCLEAN), -f) -i .omakedb -i .omakedb.lock * \end{verbatim} * * See also the \hyperfun{dependencies-proper} for an alternate method for removing intermediate files. * \end{doc} *) let filter_nodes node_exists venv pos loc args = let pos = string_pos "filter-exists" pos in match args with | [arg] -> let cache = Omake_env.venv_cache venv in let args = Omake_value.values_of_value venv pos arg in let nodes = List.map (Omake_value.file_of_value venv pos) args in let nodes = List.filter (node_exists cache venv pos) nodes in let nodes = List.map (fun v -> Omake_value_type.ValNode v) nodes in Omake_value_type.ValArray nodes | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let file_exists venv pos loc args = node_exists (fun cache _ _ node -> Omake_cache.exists cache node) venv pos loc args (* let file_exists_force venv pos loc args = *) (* node_exists (fun cache _ _ node -> Omake_cache.exists cache node) venv pos loc args *) let filter_exists venv pos loc args = filter_nodes (fun cache _ _ node -> Omake_cache.exists cache node) venv pos loc args (* Catch UnbuildableException *) let target_is_buildable cache venv pos node = try Omake_target.target_is_buildable cache venv pos node with Omake_value_type.RaiseException(_, obj) when Omake_env.venv_instanceof obj Omake_symbol.unbuildable_exception_sym -> false let target_is_buildable_proper cache venv pos node = try Omake_target.target_is_buildable_proper cache venv pos node with Omake_value_type.RaiseException(_, obj) when Omake_env.venv_instanceof obj Omake_symbol.unbuildable_exception_sym -> false let target_exists venv pos loc args = node_exists target_is_buildable venv pos loc args let filter_targets venv pos loc args = filter_nodes target_is_buildable venv pos loc args let target_is_proper venv pos loc args = node_exists target_is_buildable_proper venv pos loc args let filter_proper_targets venv pos loc args = filter_nodes target_is_buildable_proper venv pos loc args (* * \begin{doc} * \twofuns{find-targets-in-path}{find-targets-in-path-optional} * * \begin{verbatim} * $(find-targets-in-path path files) : File Array * $(find-targets-in-path-optional path, files) : File Array * path : Dir Array * files : File Sequence * \end{verbatim} * * The \verb+find-target-in-path+ function searches for targets in the * search path. For each file \verb+file+ in the file list, the path is * searched sequentially for a directory \verb+dir+ such that the target * \verb+dir/file+ exists. If so, the file \verb+dir/file+ is returned. * * For example, suppose you are building a C project, and project * contains a subdirectory \verb+src/+ containing only the files * \verb+fee.c+ and \verb+foo.c+. The following expression * evaluates to the files \verb+src/fee.o+ \verb+src/foo.o+ even * if the files have not already been built. * * \begin{verbatim} * $(find-targets-in-path lib src, fee.o foo.o) * * # Evaluates to * src/fee.o src/foo.o * \end{verbatim} * * The \verb+find-targets-in-path+ * function raises an exception if the file can't be found. * The \verb+find-targets-in-path-optional+ function silently removes * targets that can't be found. * * \begin{verbatim} * $(find-targets-in-path-optional lib src, fee.o foo.o fum.o) * * # Evaluates to * src/fee.o src/foo.o * \end{verbatim} * * \fun{find-ocaml-targets-in-path-optional} * The \verb+find-ocaml-targets-in-path-optional+ function is very similar to the * \hyperfunn{find-targets-in-path-optional} one, except an OCaml-style search * is used, where for every element of the search path and for every name being * searched for, first the uncapitalized version is tried and if it is not buildable, * then the capitalized version is tried next. * \end{doc} *) let search_target_path_aux search venv pos loc args = let pos = string_pos "search-target-path" pos in match args with [dirs; arg] -> (* List the path *) let path = Omake_value.values_of_value venv pos dirs in let path = Omake_eval.path_of_values venv pos path "." in let path = List.rev (List.fold_left (fun path (_, entry) -> List.rev_append entry path) [] path) in let cache = Omake_env.venv_cache venv in (* Find each file *) let files = Omake_value.strings_of_value venv pos arg in let files = List.fold_left (search venv cache pos loc path) [] files in Omake_value.concat_array (List.rev files) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let search_target_in_path_aux fail venv cache pos loc path files name = match Omake_target.target_is_buildable_in_path cache venv pos path [name] with | Some node -> Omake_value_type.ValNode node :: files | None -> if fail then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("target not found", name))) else files let search_ocaml_target_in_path_aux venv cache pos _loc path files name = let names = [ String.uncapitalize_ascii name; String.capitalize_ascii name ] in match Omake_target.target_is_buildable_in_path cache venv pos path names with | Some node -> Omake_value_type.ValNode node :: files | None -> files let find_targets_in_path = search_target_path_aux (search_target_in_path_aux true) let find_targets_in_path_optional = search_target_path_aux (search_target_in_path_aux false) let find_ocaml_targets_in_path_optional = search_target_path_aux search_ocaml_target_in_path_aux (* * Get the file from a string. * * \begin{doc} * \fun{file-sort} * \index{link-order sorting} * \index{sorting (link-order)} * * \begin{verbatim} * $(file-sort order, files) : File Sequence * order : String * files : File Sequence * \end{verbatim} * * \targetref{.ORDER}% * \targetref{.BUILDORDER}% * The \verb+file-sort+ function sorts a list of filenames by * build order augmented by a set of sort rules. Sort * rules are declared using the \verb+.ORDER+ target. * The \verb+.BUILDORDER+ defines the default order. * * \verb+$(file-sort , )+ * * For example, suppose we have the following set of rules. * * \begin{verbatim} * a: b c * b: d * c: d * * .DEFAULT: a b c d * echo $(file-sort .BUILDORDER, a b c d) * \end{verbatim} * * In the case, the sorter produces the result \verb+d b c a+. * That is, a target is sorted \emph{after} its dependencies. * The sorter is frequently used to sort files that are to be linked * by their dependencies (for languages where this matters). * * There are three important restrictions to the sorter: * \begin{itemize} * \item The sorter can be used only within a rule body. * The reason for this is that \emph{all} dependencies * must be known before the sort is performed. * \item The sorter can only sort files that are buildable * in the current project. * \item The sorter will fail if the dependencies are cyclic. * \end{itemize} * * \subsubsection{sort rule} * * It is possible to further constrain the sorter through the use of * sort rules. A sort rule is declared in two steps. The * target must be listed as an \verb+.ORDER+ target; and then * a set of sort rules must be given. A sort rule defines * a pattern constraint. * * \begin{verbatim} * .ORDER: .MYORDER * * .MYORDER: %.foo: %.bar * .MYORDER: %.bar: %.baz * * .DEFAULT: a.foo b.bar c.baz d.baz * echo $(sort .MYORDER, a.foo b.bar c.baz d.baz) * \end{verbatim} * * In this example, the \verb+.MYORDER+ sort rule specifies that any * file with a suffix \verb+.foo+ should be placed after any file with * suffix \verb+.bar+, and any file with suffix \verb+.bar+ should be * placed after a file with suffix \verb+.baz+. * * In this example, the result of the sort is \verb+d.baz c.baz b.bar a.foo+. * \end{doc} *) let sort_aux sorter venv pos loc args = let pos = string_pos "file-sort" pos in let name, nodes = match args with [name; arg] -> let values = Omake_value.values_of_value venv pos arg in let nodes = List.map (Omake_value.file_of_value venv pos) values in let name = Lm_symbol.add (Omake_value.string_of_value venv pos name) in name, nodes | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in let env = Omake_build_util.get_env pos loc in sorter env venv pos name nodes let sort venv pos loc args = let sorter env venv pos name nodes = let nodes = Omake_build_util.sort env venv pos name nodes in Omake_value_type.ValSequence (Omake_builtin_util.sequence_map (fun node -> Omake_value_type.ValNode node) nodes) in sort_aux sorter venv pos loc args (* * \begin{doc} * \fun{file-check-sort} * * \begin{verbatim} * file-check-sort(files) * files : File Sequence * raises RuntimeException * \end{verbatim} * * The \verb+file-check-sort+ function checks whether a list of files * is in sort order. If so, the list is returned unchanged. * If not, the function raises an exception. * * \verb+$(file-check-sort , )+ * \end{doc} *) let check_sort venv pos loc args = let sorter env venv pos name nodes = Omake_build_util.check_sort env venv pos name nodes; Omake_value_type.ValSequence (Omake_builtin_util.sequence_map (fun node -> ValNode node) nodes) in sort_aux sorter venv pos loc args (************************************************************************ * Listings. *) (* * Comparisons for forting. *) let compare_dir_node dir1 node = let dir2 = Omake_node.Node.dir node in let cmp = Omake_node.Dir.compare dir1 dir2 in if cmp = 0 then -1 else cmp let compare_val_nodes (node1 : Omake_value_type.t) (node2 : Omake_value_type.t) = match node1, node2 with | ValDir dir, ValNode node -> compare_dir_node dir node | ValNode node, ValDir dir -> -(compare_dir_node dir node) | ValDir dir1, ValDir dir2 -> Omake_node.Dir.compare dir1 dir2 | ValNode node1, ValNode node2 -> Omake_node.Node.compare node1 node2 | _ -> 0 let sort_val_nodes nodes = List.sort compare_val_nodes nodes (* * \begin{doc} * \section{Globbing and file listings} * \label{section:globbing} * * \OMake{} commands are ``glob-expanded'' before being executed. That is, * names may contain \emph{patterns} that are expanded to sequences of * file and directory names. The syntax follows the standard bash(1), csh(1), * syntax, with the following rules. * * \begin{itemize} * \item A \emph{pathname} is a sequence of directory and file names separated by * one of the \verb+/+ or \verb+\+ characters. For example, the following pathnames * refer to the same file: \verb+/home/jyh/OMakefile+ and \verb+/home\jyh/OMakefile+. * * \item Glob-expansion is performed on the components of a path. If a path contains * occurrences of special characters (listed below), the path is viewed as a pattern * to be matched against the actual files in the system. The expansion produces a * sequence of all file/directory names that match. * * For the following examples, suppose that a directory \verb+/dir+ contains files * named \verb+a+, \verb+-a+, \verb+a.b+, and \verb+b.c+. * * \begin{description} * \item[\texttt{*}] Matches any sequence of zero-or-more characters. For example, * the pattern \verb+/dir/a*+ expands to \verb+/dir/a /dir/aa /dir/a.b+. * * \item[\texttt{?}] Matches exactly one character. The pattern \verb+/dir/?a+ expands * the filename \verb+/dir/-a+. * * \item[\texttt{[...]}] Square brackets denote character sets and ranges * in the ASCII character set. The pattern may contain individual characters $c$ * or character ranges \texttt{$c_1$-$c_2$}. The pattern matches any of the * individual characters specified, or any characters in the range. A leading ``hat'' * inverts the send of the pattern. To specify a pattern that contains the * literal characters \verb+-+, the \verb+-+ should occur as the first character in * the range. * * \begin{center} * \begin{tabular}{ll} * Pattern & Expansion\\ * \hline * \verb+/dir/[a-b]*+ & \verb+/dir/a /dir/a.b /dir/b.c+\\ * \verb+/dir/[-a-b]*+ & \verb+/dir/a /dir/-a /dir/a.b /dir/b.c+\\ * \verb+/dir/[-a]*+ & \verb+/dir/a /dir/-a /dir/a.b+\\ * \end{tabular} * \end{center} * * \item[\texttt{\{s1,...,sN\}}] Braces indicate brace-expansion. * The braces delimit a sequence of strings separated by commas. * Given $N$ strings, the result produces $N$ copies of the pattern, * one for each of the strings $s_i$. * * \begin{center} * \begin{tabular}{ll} * Pattern & Expansion\\ * \hline * \verb+a{b,c,d}+ & \verb+ab ac ad+\\ * \verb+a{b{c,d},e}+ & \verb+abc abd ae+\\ * \verb+a{?{[A-Z],d},*}+ & \verb+a?[A-Z] a?d a*+ * \end{tabular} * \end{center} * * \item[\texttt{~}] The tilde is used to specify home directories. * Depending on your system, these might be possible expansions. * * \begin{center} * \begin{tabular}{ll} * Pattern & Expansion\\ * \hline * \verb+~jyh+ & \verb+/home/jyh+\\ * \verb+~bob/*.c+ & \verb+c:\Documents and Settings\users\bob+ * \end{tabular} * \end{center} * * \item[\\] The \verb+\+ character is both a pathname separator * and an escape character. If followed by a special glob character, * the \verb+\+ changes the sense of the following character to non-special * status. Otherwise, \verb+\+ is viewed as a pathname separator. * * \begin{center} * \begin{tabular}{ll} * Pattern & Expansion\\ * \hline * \verb+~jyh/\*+ & \verb+~jyh/*+ (\verb+*+ is literal)\\ * \verb+/dir/\[a-z?+ & \verb+/dir/[a-z?+ (\verb+[+ is literal, \verb+?+ is a pattern).\\ * \verb+c:\Program Files\[A-z]+ & \verb+c:\Program Files[A-z]*+ * \end{tabular} * \end{center} * * Note that the final case might be considered to be ambiguous (where \verb+\+ should * be viewed as a pathname separator, not as an escape for the subsequent \verb+[+ * character. If you want to avoid this ambiguity on Win32, you should use the * forward slash \verb+/+ even for Win32 pathnames (the \verb+/+ is translated * to \verb+\+ in the output). * * \begin{center} * \begin{tabular}{ll} * Pattern & Expansion\\ * \hline * \verb+c:/Program Files/[A-z]*+ & \verb+c:\Program Files\WindowsUpdate ...+ * \end{tabular} * \end{center} * \end{description} * \end{itemize} * * \fun{glob} * * \begin{verbatim} * $(glob strings) : Node Array * strings : String Sequence * $(glob options, strings) : Node Array * options : String * strings : String Sequence * \end{verbatim} * * The \verb+glob+ function performs glob-expansion. * * The . and .. entries are always ignored. * * The options are: * \begin{description} * \item[b] Do not perform \Cmd{csh}{1}-style brace expansion. * \item[e] The \verb+\+ character does not escape special characters. * \item[n] If an expansion fails, return the expansion literally instead of aborting. * \item[i] If an expansion fails, it expands to nothing. * \item[.] Allow wildcard patterns to match files beginning with a . * \item[A] Return all files, including files that begin with a . * \item[F] Match only normal files (any file that is not a directory). * \item[D] Match only directory files. * \item[C] Ignore files according to \Cmd{cvs}{1} rules. * \item[P] Include only proper subdirectories. * \end{description} * * In addition, the following variables may be defined that affect the * behavior of \verb+glob+. * * \begin{description} * \item[GLOB\_OPTIONS] A string containing default options. * \item[GLOB\_IGNORE] A list of shell patterns for filenames that \verb+glob+ should ignore. * \item[GLOB\_ALLOW] A list of shell patterns. If a file does not match a pattern in * \verb+GLOB_ALLOW+, it is ignored. * \end{description} * * The returned files are sorted by name. * \end{doc} *) let glob venv pos loc args = let pos = string_pos "glob" pos in let option, arg = match args with | [arg] -> Omake_value_type.ValString "", arg | [option; arg] -> option, arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in let options = Omake_rule.glob_options_of_env venv pos in let option = Omake_value.string_of_value venv pos option in let options = Omake_rule.glob_options_of_string options option in let options = Lm_glob.create_options options in let dirs = Omake_value.strings_of_value venv pos arg in let root = Omake_node.Dir.cwd () in let cwd = Omake_env.venv_dir venv in let cwd_name = Omake_node.Dir.name root cwd in let dirs, names = Lm_glob.glob options cwd_name dirs in let dirs = List.map (fun dir -> Omake_value_type.ValDir (Omake_node.Dir.chdir cwd dir)) dirs in let nodes = List.map (fun name -> Omake_value_type.ValNode (Omake_env.venv_intern venv PhonyProhibited name)) names in let nodes = dirs @ nodes in Omake_value_type.ValArray (sort_val_nodes nodes) (* * ls function. * * \begin{doc} * \fun{ls} * * \begin{verbatim} * $(ls files) : Node Array * files : String Sequence * $(ls options, files) : Node Array * files : String Sequence * \end{verbatim} * * The \verb+ls+ function returns the filenames in a directory. * * The . and .. entries are always ignored. * The patterns are shell-style patterns, and are glob-expanded. * * The options include all of the options to the \verb+glob+ function, * plus the following. * * \begin{description} * \item[R] Perform a recursive listing. * \end{description} * * The \verb+GLOB_ALLOW+ and \verb+GLOB_IGNORE+ variables can be defined * to control the globbing behavior. * The returned files are sorted by name. * \end{doc} *) let relative_filename_concat dir file = if Filename.is_relative file then Filename.concat dir file else file let ls_fun_of_string s = let len = String.length s in let rec search i = if i = len then Lm_glob.list_dirs else match s.[i] with | 'R' -> Lm_glob.list_dirs_rec | _ -> search (i + 1) in search 0 let ls venv pos loc args = let pos = string_pos "ls" pos in let option, arg = match args with | [arg] -> Omake_value_type.ValString "", arg | [option; arg] -> option, arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in let option = Omake_value.string_of_value venv pos option in let ls_fun = ls_fun_of_string option in let options = Omake_rule.glob_options_of_env venv pos in let options = Omake_rule.glob_options_of_string options option in let options = Lm_glob.create_options options in let dirs = Omake_value.strings_of_value venv pos arg in let root = Omake_node.Dir.cwd () in let cwd = Omake_node.Dir.name root (Omake_env.venv_dir venv) in let dirs, files1 = Lm_glob.glob options cwd dirs in let dirs = List.map (relative_filename_concat cwd) dirs in let files1 = List.map (relative_filename_concat cwd) files1 in let dirs, files2 = ls_fun options "" dirs in let dirs = List.map (fun dir -> Omake_value_type.ValDir (Omake_node.Dir.chdir root dir)) dirs in let nodes = List.map (fun name -> Omake_value_type.ValNode (Omake_env.venv_intern_cd venv PhonyProhibited root name)) (files1 @ files2) in let nodes = dirs @ nodes in Omake_value_type.ValArray (sort_val_nodes nodes) (* * The builtin function. * * \begin{doc} * \fun{subdirs} * * \begin{verbatim} * $(subdirs dirs) : Dir Array * dirs : String Sequence * $(subdirs options, dirs) : Dir Array * options : String * dirs : String Sequence * \end{verbatim} * * The \verb+subdirs+ function returns all the subdirectories * of a list of directories, recursively. * * The possible options are the following: * \begin{description} * \item[A] Return directories that begin with a . * \item[C] Ignore files according to \File{.cvsignore} rules. * \item[P] Include only proper subdirectories. * \end{description} * \end{doc} *) let subdirs venv pos loc args : Omake_value_type.t = let pos = string_pos "subdirs" pos in let option, arg = match args with | [arg] -> Omake_value_type.ValString "", arg | [options; arg] -> options, arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let options = Omake_rule.glob_options_of_env venv pos in let options = Omake_rule.glob_options_of_string options (Omake_value.string_of_value venv pos option) in let options = Lm_glob.create_options options in let dirs = Omake_value.strings_of_value venv pos arg in let root = Omake_node.Dir.cwd () in let cwd = Omake_node.Dir.name root (Omake_env.venv_dir venv) in let dirs = List.map (relative_filename_concat cwd) dirs in let dirs = Lm_glob.subdirs_of_dirs options "" dirs in let dirs = List.map (fun dir -> Omake_value_type.ValDir (Omake_node.Dir.chdir root dir)) dirs in ValArray dirs (************************************************************************ * Argument parsing. *) (* * Modes can be specified in two forms: * 1. As octal numbers * 2. In the symbolic format * u+rg-wx etc *) type mode_op = ModeSet | ModeAdd | ModeSub type chmod_mode = ChmodInt of int | ChmodString of string | ChmodNone (* * Mode bit operations. *) let add_mode_bit mode mask op bits = let bits = ((bits lsl 6) lor (bits lsl 3) lor bits) land mask in match op with ModeSet -> (mode land (lnot mask)) lor bits | ModeAdd -> mode lor bits | ModeSub -> mode land (lnot bits) let add_abs_mode_bit mode op bit = match op with ModeSet | ModeAdd -> mode lor bit | ModeSub -> mode land (lnot bit) (* * Symbolic modes: * [ugoa]*[+-=][rwxXstugo]* *) let mode_of_symbolic_component mode s = let len = String.length s in let rec parse_bits mode mask op i = if i = len then mode else let mode = match s.[i] with 'r' -> add_mode_bit mode mask op 0b100 | 'w' -> add_mode_bit mode mask op 0b010 | 'x' -> add_mode_bit mode mask op 0b001 | 'X' -> if (mode land 0o111) = 0 then mode else add_mode_bit mode mask op 0b001 | 's' -> let bit = if (mask land 0o770) <> 0 then 0o6000 else if (mask land 0o700) <> 0 then 0o4000 else if (mask land 0o070) <> 0 then 0o2000 else raise (Failure "mode_of_string") in add_abs_mode_bit mode op bit | 't' -> add_abs_mode_bit mode op 0o1000 | 'u' -> add_mode_bit mode mask op ((mode lsr 6) land 7) | 'g' -> add_mode_bit mode mask op ((mode lsr 3) land 7) | 'o' -> add_mode_bit mode mask op (mode land 7) | _ -> raise (Failure "mode_of_string") in parse_bits mode mask op (succ i) in let rec parse_mode mode mask i = if i = len then mode else match s.[i] with 'u' -> parse_mode mode (mask lor 0o700) (succ i) | 'g' -> parse_mode mode (mask lor 0o070) (succ i) | 'o' -> parse_mode mode (mask lor 0o007) (succ i) | 'a' -> parse_mode mode (mask lor 0o777) (succ i) | '+' -> parse_bits mode mask ModeAdd (succ i) | '-' -> parse_bits mode mask ModeSub (succ i) | '=' -> parse_bits mode mask ModeSet (succ i) | _ -> raise (Failure "mode_of_string") in parse_mode mode 0 0 let mode_of_symbolic_string mode s = List.fold_left mode_of_symbolic_component mode (Lm_string_util.split "," s) let mode_of_string mode s = if s = "" then mode else match s.[0] with '0'..'7' -> int_of_string ("0o" ^ s) | _ -> mode_of_symbolic_string mode s let mode_of_chmod mode = function ChmodNone -> mode | ChmodInt mode -> mode | ChmodString s -> mode_of_string mode s (************************************************************************ * Directories. *) (* * \begin{doc} * \section{Filesystem operations} * \fun{mkdir} * * \begin{verbatim} * mkdir(mode, node...) * mode : Int * node : Node * raises RuntimeException * * mkdir(node...) * node : Node * raises RuntimeException * \end{verbatim} * * The \verb+mkdir+ function creates a directory, or a set of directories. * The following options are supported. * \begin{description} * \item[-m mode] Specify the permissions of the created directory. * \item[-p] Create parent directories if they do not exist. * \item[--] Interpret the remaining names literally. * \end{description} * \end{doc} *) type mkdir_info = { mkdir_mode : int; mkdir_parents : bool; mkdir_files : string list } let mkdir_default_info = { mkdir_mode = 0o777; mkdir_parents = false; mkdir_files = [] } let mkdir_spec = Lm_arg.MultiLetterOptions, (**) ["options", (**) ["-m", (**) Lm_arg.StringFold (fun info s -> { info with mkdir_mode = mode_of_string info.mkdir_mode s }), "set permission mode"; "-p", (**) Lm_arg.UnitFold (fun info -> { info with mkdir_parents = true }), "make parents as needed"; "--", (**) RestFold (fun info s -> { info with mkdir_files = s :: info.mkdir_files }), "the rest of the arguments are interpreted literally"]] let mkdir_default info s = { info with mkdir_files = s :: info.mkdir_files }, false let mkdir_usage = "Create a directory" let mkdir venv pos loc args = let pos = string_pos "mkdir" pos in let info, nodes = match args with [mode; nodes] -> let info = { mkdir_default_info with mkdir_mode = Omake_value.int_of_value venv pos mode } in info, nodes | [nodes] -> mkdir_default_info, nodes | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (1, 2), List.length args))) in let argv = Array.of_list ("mkdir" :: Omake_value.strings_of_value venv pos nodes) in let info = try Lm_arg.fold_argv argv mkdir_spec info mkdir_default mkdir_usage with Failure s -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError s)) in let mode = info.mkdir_mode in let mkdir = if info.mkdir_parents then Lm_filename_util.mkdirhier else Unix.mkdir in let () = try List.iter (fun s -> let name = Omake_node.Dir.fullname (Omake_env.venv_intern_dir venv s) in mkdir name mode) info.mkdir_files with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone (************************************************************************ * Stat. *) (* * \begin{doc} * \obj{Stat} * * The \verb+Stat+ object represents an information about a filesystem node, * as returned by the \verb+stat+ and \verb+lstat+ functions. * It contains the following fields. * * \begin{description} * \item[dev]: the device number. * \item[ino]: the inode number. * \item[kind]: the kind of the file, one of the following: * \verb+REG+ (regular file), * \verb+DIR+ (directory), * \verb+CHR+ (character device), * \verb+BLK+ (block device), * \verb+LNK+ (symbolic link), * \verb+FIFO+ (named pipe), * \verb+SOCK+ (socket). * \item[perm]: access rights, represented as an integer. * \item[nlink]: number of links. * \item[uid]: user id of the owner. * \item[gid]: group id of the file's group. * \item[rdev]: device minor number. * \item[size]: size in bytes. * \item[atime]: last access time, as a floating point number. * \item[mtime]: last modification time, as a floating point number. * \item[ctime]: last status change time, as a floating point number. * \end{description} * * Not all of the fields will have meaning on all operating systems. * * \twofuns{stat}{lstat} * * \begin{verbatim} * $(stat node...) : Stat * node : Node or Channel * $(lstat node...) : Stat * node : Node or Channel * raises RuntimeException * \end{verbatim} * * The \verb+stat+ functions return file information. * If the file is a symbolic link, the \verb+stat+ function refers to the * destination of the link; the \verb+lstat+ function refers to the link * itself. * \end{doc} *) (* * XXX: JYH: HACK: if the file size is too large, * represent it as a string. We may want to make * 64-bit ints a representable type. *) let max_file_size = Int64.of_int max_int let clip_size i = if i > max_file_size then Omake_value_type.ValData (Int64.to_string i) else Omake_value_type.ValInt (Int64.to_int i) let create_stat_obj obj stat = let obj = Omake_env.venv_add_field_internal obj Omake_symbol.st_dev_sym (ValInt stat.Unix.LargeFile.st_dev) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.st_ino_sym (ValInt stat.Unix.LargeFile.st_ino) in let kind = match stat.Unix.LargeFile.st_kind with Unix.S_REG -> "REG" | Unix.S_DIR -> "DIR" | Unix.S_CHR -> "CHR" | Unix.S_BLK -> "BLK" | Unix.S_LNK -> "LNK" | Unix.S_FIFO -> "FIFO" | Unix.S_SOCK -> "SOCK" in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.st_kind_sym (ValString kind) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.st_perm_sym (ValInt stat.st_perm) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.st_nlink_sym (ValInt stat.st_nlink) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.st_uid_sym (ValInt stat.st_uid) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.st_gid_sym (ValInt stat.st_gid) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.st_rdev_sym (ValInt stat.st_rdev) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.st_size_sym (clip_size stat.st_size) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.st_atime_sym (ValFloat stat.st_atime) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.st_mtime_sym (ValFloat stat.st_mtime) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.st_ctime_sym (ValFloat stat.st_ctime) in Omake_value_type.ValObject obj let stat_aux stat_fun venv pos loc args = let pos = string_pos "stat" pos in let obj = Omake_env.venv_find_object_or_empty venv Omake_var.stat_object_var in match args with [arg] -> let args = Omake_value.values_of_value venv pos arg in let stats = List.map (fun arg -> let file = Omake_value.filename_of_value venv pos arg in let stat = try stat_fun file with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in create_stat_obj obj stat) args in Omake_value.concat_array stats | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let stat = stat_aux Unix.LargeFile.stat let lstat = if Sys.os_type = "Win32" then stat_aux Unix.LargeFile.stat else stat_aux Unix.LargeFile.lstat (************************************************************************ * Links. *) (* * \begin{doc} * \fun{unlink} * * \begin{verbatim} * $(unlink file...) * file : File * #(rm file...) * file : File * $(rmdir dir...) * dir : Dir * raises RuntimeException * \end{verbatim} * * The \verb+unlink+ and \verb+rm+ functions remove a file. * The \verb+rmdir+ function removes a directory. * * The following options are supported for \verb+rm+ and \verb+rmdir+. * \begin{description} * \item[-f] ignore nonexistent files, never prompt. * \item[-i] prompt before removal. * \item[-r] remove the contents of directories recursively. * \item[-v] explain what is going on. * \item[--] the rest of the values are interpreted literally. * \end{description} * \end{doc} *) let unlink_aux rm_fun venv pos loc args = let pos = string_pos "unlink" pos in match args with [arg] -> let args = Omake_value.values_of_value venv pos arg in let cache = Omake_env.venv_cache venv in let () = try List.iter (fun arg -> let name = Omake_value.filename_of_value venv pos arg in let node = Omake_env.venv_intern_cd venv PhonyProhibited (Omake_node.Dir.cwd ()) name in rm_fun name; ignore (Omake_cache.reset cache node)) args with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let unlink = unlink_aux Unix.unlink (* * Command-line versions. *) type rm_info = { rm_force : bool; rm_recursive : bool; rm_interactive : bool; rm_verbose : bool; rm_files : string list } let rm_default_info = { rm_force = false; rm_recursive = false; rm_interactive = false; rm_verbose = false; rm_files = [] } let rm_spec = Lm_arg.MultiLetterOptions, (**) ["options", (**) ["-f", (**) Lm_arg.UnitFold (fun info -> { info with rm_force = true }), "force removal, never prompt"; "-i", (**) UnitFold (fun info -> { info with rm_interactive = true }), "prompt before removal"; "-r", (**) UnitFold (fun info -> { info with rm_recursive = true }), "remove the contents of directories recursively"; "-R", (**) UnitFold (fun info -> { info with rm_recursive = true }), "remove the contents of directories recursively"; "--recursive", (**) UnitFold (fun info -> { info with rm_recursive = true }), "remove the contents of directories recursively"; "-v", (**) UnitFold (fun info -> { info with rm_verbose = true }), "explain what is being done"; "--", (**) RestFold (fun info s -> { info with rm_files = s :: info.rm_files }), "the rest of the arguments are interpreted literally"]] let rm_default info s = { info with rm_files = s :: info.rm_files }, false let rm_usage = "Remove files and directories" (* * Remove a directory, with options. *) let rm_aux unlink info filename = if info.rm_force then try unlink filename with Unix.Unix_error _ -> () else let rm_flag = if info.rm_interactive then begin Lm_printf.printf "Remove %s? " filename; Lm_printf.flush Lm_printf.std_formatter; match String.lowercase_ascii (Lm_string_util.trim (input_line stdin)) with "y" | "yes" -> true | _ -> false end else true in if rm_flag then begin if info.rm_verbose then Lm_printf.printf "Removing %s@." filename; unlink filename end (* * Remove a directory or file recursively. *) let rec rm_rec info filename = let rm_fun fn = try Unix.unlink fn with | Unix.Unix_error((Unix.EISDIR | Unix.EPERM),_,_) -> Array.iter (fun name -> rm_rec info (Filename.concat fn name)) (Sys.readdir fn); Unix.rmdir fn | Unix.Unix_error(Unix.EACCES,_,_) when is_dir_no_symlink fn -> (* Windows *) Array.iter (fun name -> rm_rec info (Filename.concat fn name)) (Sys.readdir fn); Unix.rmdir fn in rm_aux rm_fun info filename (* * Main command. *) let rm_command rm_fun venv pos loc args = let pos = string_pos "rm" pos in let argv = match args with [arg] -> Array.of_list ("rm" :: Omake_value.strings_of_value venv pos arg) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let info = try Lm_arg.fold_argv argv rm_spec rm_default_info rm_default rm_usage with Failure s -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError s)) in let nodes = List.rev_map (Omake_env.venv_intern venv PhonyProhibited) info.rm_files in let files = List.map Omake_node.Node.fullname nodes in let cache = Omake_env.venv_cache venv in let () = List.iter (fun node -> Omake_cache.reset cache node) nodes; try if info.rm_recursive then List.iter (rm_rec info) files else List.iter (rm_aux rm_fun info) files with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone let rmdir = rm_command Unix.rmdir let rm = rm_command Unix.unlink (* * \begin{doc} * \fun{rename} * * \begin{verbatim} * rename(old, new) * old : Node * new : Node * mv(nodes... dir) * nodes : Node Sequence * dir : Dir * cp(nodes... dir) * nodes : Node Sequence * dir : Dir * raises RuntimeException * \end{verbatim} * * The \verb+rename+ function changes the name of a file or directory named \verb+old+ * to \verb+new+. * * The \verb+mv+ function is similar, but if \verb+new+ is a directory, and it exists, * then the files specified by the sequence are moved into the directory. If not, * the behavior of \verb+mv+ is identical to \verb+rename+. The \verb+cp+ function * is similar, but the original file is not removed. * * The \verb+mv+ and \verb+cp+ functions take the following options. * \begin{description} * \item[-f] Do not prompt before overwriting. * \item[-i] Prompt before overwriting. * \item[-v] Explain what it happening. * \item[-r] Copy the contents of directories recursively. * \item[--] Interpret the remaining arguments literally. * \end{description} * \end{doc} *) let rename venv pos loc args = let pos = string_pos "rename" pos in match args with [node1; node2] -> let name1 = Omake_value.filename_of_value venv pos node1 in let name2 = Omake_value.filename_of_value venv pos node2 in let () = try Unix.rename name1 name2 with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Command-line versions. *) let rec split_last l' l = match l with [h] -> List.rev l', h | h :: l -> split_last (h :: l') l | [] -> raise (Invalid_argument "split_last") type mv_info = { mv_force : bool; mv_interactive : bool; mv_verbose : bool; mv_recursive : bool; mv_mode : string; mv_files : string list } let mv_default_info = { mv_force = false; mv_interactive = false; mv_verbose = false; mv_recursive = false; mv_mode = ""; mv_files = [] } let mv_spec = Lm_arg.MultiLetterOptions, (**) ["options", (**) ["-f", (**) Lm_arg.UnitFold (fun info -> { info with mv_force = true }), "force removal, never prompt"; "-i", (**) UnitFold (fun info -> { info with mv_interactive = true }), "prompt before removal"; "-v", (**) UnitFold (fun info -> { info with mv_verbose = true }), "explain what is being done"; "-r", (**) UnitFold (fun info -> { info with mv_recursive = true }), "copy contents recursively"; "-m", (**) Lm_arg.StringFold (fun info s -> { info with mv_mode = s }), "specify the permissions of the copied file"; "--", (**) RestFold (fun info s -> { info with mv_files = s :: info.mv_files }), "the rest of the arguments are interpreted literally"]] let mv_default info s = { info with mv_files = s :: info.mv_files }, false let mv_usage = "Move files and directories" (* * Prompter. *) let mv_prompt info file1 file2 = if info.mv_force then true else let flag = if info.mv_interactive && Sys.file_exists file2 then begin Lm_printf.printf "Remove %s? @?" file2; match String.lowercase_ascii (Lm_string_util.trim (input_line stdin)) with "y" | "yes" -> true | _ -> false end else true in if flag && info.mv_verbose then Lm_printf.printf "Copying %s to %s@." file1 file2; flag (* * The main function. *) let mv_aux mv venv pos loc args = let pos = string_pos "mv" pos in let argv = match args with | [args] -> Array.of_list ("mv" :: Omake_value.strings_of_value venv pos args) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let info = try Lm_arg.fold_argv argv mv_spec mv_default_info mv_default mv_usage with Failure s -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError s)) in let files = List.map (fun name -> Omake_node.Dir.fullname (Omake_env.venv_intern_dir venv name)) (List.rev info.mv_files) in let files, dir = match files with [] -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, 0))) | _ -> split_last [] files in let () = try if is_dir dir then List.iter (fun file -> mv info file (Filename.concat dir (Filename.basename file))) files else match files with [file] -> mv info file dir | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("destination directory does not exist", dir))) with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone (* * Recursive copy. *) let cp_file info file1 file2 = if mv_prompt info file1 file2 then let mode = (Unix.LargeFile.stat file1).Unix.LargeFile.st_perm in let mode = mode_of_string mode info.mv_mode in let fdr = Lm_unix_util.openfile file1 [Unix.O_RDONLY] 0 in let () = if info.mv_force then try Unix.unlink file2 with Unix.Unix_error _ -> try Unix.chmod file2 0o200 with Unix.Unix_error _ -> () in let fdw = try Lm_unix_util.openfile file2 [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 0o200 with exn -> Unix.close fdr; raise exn in try let max = 4096 in let buffer = Bytes.create max in let rec loop () = let count = Unix.read fdr buffer 0 max in if count <> 0 then let rec write off = if off < count then write (off + Unix.write fdw buffer off (count - off)) in write 0; loop () in loop (); Unix.close fdr; Unix.close fdw; try Unix.chmod file2 mode with Unix.Unix_error _ -> () with exn -> Unix.close fdr; Unix.close fdw; raise exn let rec cp_rec info file1 file2 = if is_dir file1 then let subnames = Sys.readdir file1 in Unix.mkdir file2 0o777; Array.iter (fun name -> let file1 = Filename.concat file1 name in let file2 = Filename.concat file2 name in cp_rec info file1 file2) subnames else cp_file info file1 file2 let cp_files info file1 file2 = if info.mv_recursive then cp_rec info file1 file2 else cp_file info file1 file2 let cp = mv_aux cp_files let mv_file info file1 file2 = if mv_prompt info file1 file2 then try Unix.rename file1 file2 with Unix.Unix_error _ -> cp_file info file1 file2; Unix.unlink file1 let mv = mv_aux mv_file (* * \begin{doc} * \fun{link} * * \begin{verbatim} * link(src, dst) * src : Node * dst : Node * raises RuntimeException * \end{verbatim} * * The \verb+link+ function creates a hard link named \verb+dst+ to the file * or directory \verb+src+. * * Hard links may work under Win32 when NTFS is used. * * Normally, only the superuser can create hard links to directories. * \end{doc} *) let link venv pos loc args = let pos = string_pos "link" pos in match args with [src; dst] -> let src = Omake_value.filename_of_value venv pos src in let dst = Omake_value.filename_of_value venv pos dst in let () = try Unix.link src dst with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * \begin{doc} * \twofuns{symlink}{symlink-raw} * * \begin{verbatim} * symlink(src, dst) * src : Node * dst : Node * symlink-raw(src, dst) * src : String * dst : Node * raises RuntimeException * \end{verbatim} * * The \verb+symlink+ function creates a symbolic link \verb+dst+ that * points to the \verb+src+ file. * * For \verb+symlink+, the link name is computed relative to * the target directory. For example, the expression * \verb+$(symlink a/b, c/d)+ creates a link named * \verb+c/d -> ../a/b+. * * The function \verb+symlink-raw+ performs no translation. * The symbolic link is set to the \verb+src+ string. * * Symbolic links are not supported in Win32. Consider using the \verb+ln-or-cp+ * \verb+Shell+ alias for cross-platform portable linking/copying. * \end{doc} *) let symlink venv pos loc args = let pos = string_pos "symlink" pos in match args with | [src; dst] -> let dst = Omake_value.file_of_value venv pos dst in let src = Omake_value.file_of_value venv pos src in let src = Omake_node.Node.name (Omake_node.Node.dir dst) src in let dst = Omake_node.Node.fullname dst in let () = try Unix.symlink src dst with (Unix.Unix_error _ | Invalid_argument _) as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let symlink_raw venv pos loc args = let pos = string_pos "symlink-raw" pos in match args with | [src; dst] -> let dst = Omake_value.file_of_value venv pos dst in let src = Omake_value.string_of_value venv pos src in let dst = Omake_node.Node.fullname dst in let () = try Unix.symlink src dst with (Unix.Unix_error _ | Invalid_argument _) as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * \begin{doc} * \twofuns{readlink}{readlink-raw} * * \begin{verbatim} * $(readlink node...) : Node * node : Node * $(readlink-raw node...) : String * node : Node * \end{verbatim} * * The \verb+readlink+ function reads the value of a symbolic link. * \end{doc} *) let readlink venv pos loc args = let pos = string_pos "readlink" pos in match args with | [arg] -> let args = Omake_value.values_of_value venv pos arg in let args = try List.map (fun arg -> let node = Omake_value.file_of_value venv pos arg in let dir = Omake_node.Node.dir node in let name = Omake_node.Node.fullname node in let name = Unix.readlink name in Omake_value_type.ValNode (Omake_env.venv_intern_cd venv PhonyProhibited dir name)) args with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value.concat_array args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let readlink_raw venv pos loc args = let pos = string_pos "readlink-raw" pos in match args with [arg] -> let args = Omake_value.values_of_value venv pos arg in let args = try List.map (fun arg -> let node = Omake_value.file_of_value venv pos arg in let name = Omake_node.Node.fullname node in let name = Unix.readlink name in Omake_value_type.ValData name) args with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value.concat_array args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (************************************************************************ * Permissions. *) (* * \begin{doc} * \fun{chmod} * * \begin{verbatim} * chmod(mode, dst...) * mode : Int * dst : Node or Channel * chmod(mode dst...) * mode : String * dst : Node Sequence * raises RuntimeException * \end{verbatim} * * The \verb+chmod+ function changes the permissions of the targets. * * Options: * \begin{description} * \item[-v] Explain what is happening. * \item[-r] Change files and directories recursively. * \item[-f] Continue on errors. * \item[--] Interpret the remaining argument literally. * \end{description} * \end{doc} *) type chmod_info = { chmod_mode : chmod_mode; chmod_rec : bool; chmod_force : bool; chmod_verbose : bool; chmod_files : string list } let chmod_default_info = { chmod_mode = ChmodNone; chmod_rec = false; chmod_force = false; chmod_verbose = false; chmod_files = [] } let chmod_spec = Lm_arg.MultiLetterOptions, (**) ["options", (**) ["-m", (**) Lm_arg.StringFold (fun info s -> { info with chmod_mode = ChmodString s }), "set permission mode"; "-r", (**) UnitFold (fun info -> { info with chmod_rec = true }), "change permission recursively"; "-f", (**) UnitFold (fun info -> { info with chmod_force = true }), "do not fail on errors"; "-v", (**) UnitFold (fun info -> { info with chmod_verbose = true }), "explain what is happening"; "--", (**) RestFold (fun info s -> { info with chmod_files = s :: info.chmod_files }), "the rest of the arguments are interpreted literally"]] let chmod_default info s = { info with chmod_files = s :: info.chmod_files }, false let chmod_usage = "Change file permissions" (* * Actual chmod command. *) let chmod info filename = if info.chmod_verbose then Lm_printf.printf "Changing permissions on %s@." filename; let mode = (Unix.LargeFile.stat filename).Unix.LargeFile.st_perm in let mode = mode_of_chmod mode info.chmod_mode in if info.chmod_force then try Unix.chmod filename mode with Unix.Unix_error _ -> () else Unix.chmod filename mode (* * Recursive versions. *) let rec chmod_rec info filename = let subnames = try Sys.readdir filename with Sys_error _ -> [||] in Array.iter (fun name -> chmod_rec info (Filename.concat filename name)) subnames; chmod info filename (* * The command-line version. *) let chmod venv pos loc args = let pos = string_pos "chmod" pos in let info, nodes = match args with [mode; nodes] -> let mode = match mode with |Omake_value_type.ValInt mode -> ChmodInt mode | _ -> let s = Omake_value.string_of_value venv pos mode in try ChmodInt (int_of_string s) with Failure _ -> ChmodString s in let info = { chmod_default_info with chmod_mode = mode } in info, nodes | [nodes] -> chmod_default_info, nodes | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (1, 2), List.length args))) in let argv = Array.of_list ("chmod" :: Omake_value.strings_of_value venv pos nodes) in let info = try Lm_arg.fold_argv argv chmod_spec info chmod_default chmod_usage with Failure s -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError s)) in let info, files = if info.chmod_mode <> ChmodNone then info, info.chmod_files else match List.rev info.chmod_files with mode :: rest -> let info = { info with chmod_mode = ChmodString mode } in info, rest | [] -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let files = List.map (fun name -> Omake_node.Dir.fullname (Omake_env.venv_intern_dir venv name)) files in let () = if info.chmod_rec then List.iter (chmod_rec info) files else List.iter (chmod info) files in Omake_value_type.ValNone (* * \begin{doc} * \fun{chown} * * \begin{verbatim} * chown(uid, gid, node...) * uid : Int * gid : Int * node : Node or Channel * chown(uid, node...) * uid : Int * node : Node or Channel * raises RuntimeException * \end{verbatim} * * The \verb+chown+ function changes the user and group id of the file. * If the \verb+gid+ is not specified, it is not changed. If either * id is -1, that id is not changed. * \end{doc} *) let chown venv pos loc args = let pos = string_pos "chown" pos in let uid, gid, nodes = match args with [uid; nodes] -> uid, None, nodes | [uid; gid; nodes] -> uid, Some gid, nodes | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (2, 3), List.length args))) in let uid = Omake_value.int_of_value venv pos uid in let gid = match gid with Some gid -> Omake_value.int_of_value venv pos gid | None -> -1 in let nodes = Omake_value.values_of_value venv pos nodes in let () = try List.iter (fun node -> Unix.chown (Omake_value.filename_of_value venv pos node) uid gid) nodes with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone (* * \begin{doc} * \fun{utimes} * * \begin{verbatim} * utimes(atime, mtime, node...) * atime : Float * mtime : Float * node : Node * raises RuntimeException * \end{verbatim} * * The \verb+utimes+ function changes the access and modification * times of the files. * \end{doc} *) let utimes venv pos loc args = let pos = string_pos "utimes" pos in let atime, mtime, nodes = match args with | [atime; mtime; nodes] -> atime, mtime, nodes | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 3, List.length args))) in let atime = Omake_value.float_of_value venv pos atime in let mtime = Omake_value.float_of_value venv pos mtime in let nodes = Omake_value.values_of_value venv pos nodes in let () = try List.iter (fun node -> Unix.utimes (Omake_value.filename_of_value venv pos node) atime mtime) nodes with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone (* * \begin{doc} * \fun{truncate} * * \begin{verbatim} * truncate(length, node...) * length : Int * node : Node or Channel * raises RuntimeException * \end{verbatim} * * The \verb+truncate+ function truncates a file to the given length. * \end{doc} *) let truncate venv pos loc args = let pos = string_pos "truncate" pos in let len, nodes = match args with [len; nodes] -> len, nodes | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in let len = Omake_value.int_of_value venv pos len in let nodes = Omake_value.values_of_value venv pos nodes in let () = try List.iter (fun node -> Unix.truncate (Omake_value.filename_of_value venv pos node) len) nodes with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValNone (* * \begin{doc} * \fun{umask} * * \begin{verbatim} * $(umask mode) : Int * mode : Int * raises RuntimeException * \end{verbatim} * * Sets the file mode creation mask. * The previous mask is returned. * This value is not scoped, changes have global effect. * \end{doc} *) let umask venv pos loc args = let pos = string_pos "umask" pos in match args with | [arg] -> let mode = Omake_value.int_of_value venv pos arg in let mask = try Unix.umask mode with Unix.Unix_error _ as exn -> raise (Omake_value_type.UncaughtException (pos, exn)) in Omake_value_type.ValInt mask | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \section{vmount} * \fun{vmount} * * \begin{verbatim} * vmount(src, dst) * src, dst : Dir * vmount(flags, src, dst) * flags : String * src, dst : Dir * \end{verbatim} * * ``Mount'' the \verb+src+ directory on the \verb+dst+ directory. This is * a virtual mount, changing the behavior of the \verb+$(file ...)+ function. * When the \verb+$(file str)+ function is used, the resulting file is taken * relative to the \verb+src+ directory if the file exists. Otherwise, the * file is relative to the current directory. * * The main purpose of the \verb+vmount+ function is to support multiple * builds with separate configurations or architectures. * * The options are as follows. * \begin{description} * \item[l] Create symbolic links to files in the \verb+src+ directory. * \item[c] Copy files from the \verb+src+ directory. * \end{description} * * Mount operations are scoped. * \end{doc} *) type vmount_flags = MountForce let vmount_flags pos loc s = let pos = string_pos "vmount_flags" pos in let len = String.length s in let rec collect local_flags mount_flags i = if i = len then local_flags, mount_flags else let local_flags, mount_flags = match s.[i] with | 'l' -> local_flags, Omake_node_sig.MountLink :: mount_flags | 'c' -> local_flags, MountCopy :: mount_flags | 'f' -> MountForce :: local_flags, mount_flags | '-' | ' ' -> local_flags, mount_flags | c -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("illegal vmount option", String.make 1 c))) in collect local_flags mount_flags (succ i) in collect [] [] 0 (* * Refer to all the files in the source directory, so that * they get copied. *) let vmount_touch_files venv pos src dst = let _pos = string_pos "vmount_touch_files" pos in let src_name = Omake_node.Dir.fullname src in let dst_name = Omake_node.Dir.name src dst in let options = Lm_glob.create_options [GlobIgnore [dst_name]] in let _, files = Lm_glob.list_dirs_rec options src_name ["."] in List.iter (fun name -> ignore (Omake_env.venv_intern_cd venv PhonyProhibited dst name)) files (* * Add the mount. *) let vmount venv pos loc args kargs = let pos = string_pos "vmount" pos in let flags, src, dst = match args, kargs with [src; dst], [] -> "", src, dst | [flags; src; dst], [] -> Omake_value.string_of_value venv pos flags, src, dst | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (2, 3), List.length args))) in let local_flags, mount_flags = vmount_flags pos loc flags in let src = Omake_value.dir_of_value venv pos src in let dst = Omake_value.dir_of_value venv pos dst in let venv = Omake_env.venv_mount venv mount_flags src dst in if List.mem MountForce local_flags then vmount_touch_files venv pos src dst; venv, Omake_value_type.ValNone (* * \begin{doc} * \fun{add-project-directories} * * \begin{verbatim} * add-project-directories(dirs) * dirs : Dir Array * \end{verbatim} * * Add the directories to the set of directories that omake considers to be part * of the project. This is mainly used to avoid omake complaining that the * current directory is not part of the project. * \end{doc} *) let add_project_directories venv pos loc args = let pos = string_pos "add-project-directories" pos in match args with | [arg] -> let values = Omake_value.values_of_value venv pos arg in List.iter (fun v -> Omake_env.venv_add_explicit_dir venv (Omake_value.dir_of_value venv pos v)) values; Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{remove-project-directories} * * \begin{verbatim} * remove-project-directories(dirs) * dirs : Dir Array * \end{verbatim} * * Removed the directories from the set of directories that omake considers to be part * of the project. This is mainly used to cancel a \verb+.SUBDIRS+ from including * a directory if it is determined that the directory does not need to be compiled. * \end{doc} *) let remove_project_directories venv pos loc args = let pos = string_pos "add-project-directories" pos in match args with | [arg] -> let values = Omake_value.values_of_value venv pos arg in List.iter (fun v -> Omake_env.venv_remove_explicit_dir venv (Omake_value.dir_of_value venv pos v)) values; Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (************************************************************************ * Tables. *) let () = let builtin_funs = [true, "file-sort", sort, Omake_ir.ArityExact 2; true, "file-check-sort", check_sort, ArityExact 2; true, "ls", ls, ArityRange (1, 2); true, "glob", glob, ArityRange (1, 2); true, "subdirs", subdirs, ArityRange (1, 2); true, "basename", basename, ArityExact 1; true, "dirname", dirname, ArityExact 1; true, "homename", homename, ArityExact 1; true, "rootname", rootname, ArityExact 1; true, "fullname", fullname, ArityExact 1; true, "absname", absname, ArityExact 1; true, "suffix", suffix, ArityExact 1; true, "tmpfile", tmpfile, ArityRange (1, 2); true, "file", file, ArityExact 1; true, "dir", dir, ArityExact 1; true, "which", which, ArityExact 1; true, "where", where, ArityExact 1; true, "exists-in-path", exists_in_path, ArityExact 1; true, "in", ind, ArityExact 2; true, "dirof", dirof, ArityExact 1; true, "stat-reset", stat_reset, ArityExact 1; true, "file-exists", file_exists, ArityExact 1; true, "filter-exists", filter_exists, ArityExact 1; true, "target-exists", target_exists, ArityExact 1; true, "filter-targets", filter_targets, ArityExact 1; true, "target-is-proper", target_is_proper, ArityExact 1; true, "filter-proper-targets", filter_proper_targets, ArityExact 1; true, "stat", stat, ArityExact 1; true, "lstat", lstat, ArityExact 1; true, "unlink", unlink, ArityExact 1; true, "rename", rename, ArityExact 2; true, "readlink", readlink, ArityExact 1; true, "readlink-raw", readlink_raw, ArityExact 1; true, "truncate", truncate, ArityExact 2; true, "mkdir", mkdir, ArityRange (1, 2); true, "rmdir", rmdir, ArityExact 1; true, "rm", rm, ArityExact 1; true, "mv", mv, ArityExact 1; true, "cp", cp, ArityExact 1; true, "link", link, ArityExact 2; true, "symlink", symlink, ArityExact 2; true, "symlink-raw", symlink_raw, ArityExact 2; true, "chmod", chmod, ArityExact 2; true, "chown", chown, ArityRange (2, 3); true, "utimes", utimes, ArityExact 3; true, "umask", umask, ArityExact 1; true, "digest-string", digest_string, ArityExact 1; true, "digest", digest, ArityExact 1; true, "digest-optional", digest_optional, ArityExact 1; true, "find-in-path", find_in_path, ArityExact 2; true, "find-in-path-optional", find_in_path_optional, ArityExact 2; true, "digest-in-path", digest_in_path, ArityExact 2; true, "digest-in-path-optional", digest_in_path_optional, ArityExact 2; true, "rehash", rehash, ArityExact 0; true, "find-targets-in-path", find_targets_in_path, ArityExact 2; true, "find-targets-in-path-optional", find_targets_in_path_optional, ArityExact 2; true, "find-ocaml-targets-in-path-optional", find_ocaml_targets_in_path_optional, ArityExact 2; true, "add-project-directories", add_project_directories, ArityExact 1; true, "remove-project-directories", remove_project_directories, ArityExact 1] in let builtin_kfuns = [true, "vmount", vmount, Omake_ir.ArityRange (2, 3); ] in let pervasives_objects = ["Tm";] in let builtin_info = {Omake_builtin_type.builtin_empty with builtin_funs = builtin_funs; builtin_kfuns = builtin_kfuns; pervasives_objects = pervasives_objects } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_builtin_base.ml0000644000175000017500000027421213177364666017751 0ustar gerdgerd(* * Some builtin functions. * * \begin{doc} * \chapter{Base library} * \label{chapter:base} * \cutname{omake-base.html} * \end{doc} *) include Omake_pos.Make (struct let name = "Omake_builtin_base" end) (* * Table of variables. * * \begin{doc} * \section{Builtin variables} * \varlabel{OMAKE_VERSION}{OMAKE\_VERSION} * Version of \OMake. * \var{STDLIB} * The directory where the \OMake{} standard library files reside. At startup, the default * value is determined as follows. * \begin{itemize} * \item The value of the \verb+OMAKELIB+ environment variable, if set (must contain * an absolute path, if set), otherwise * \item On Windows, the registry keys \verb+HKEY_CURRENT_USER\SOFTWARE\MetaPRL\OMake\OMAKELIB+ and * \verb+HKEY_LOCAL_MACHINE\SOFTWARE\MetaPRL\OMake\OMAKELIB+ are looked up and the value is used, * if exist. * \item Otherwise a compile-time default it used. * \end{itemize} * The current default value may be accessed by running \verb+omake --version+ * \var{OMAKEPATH} * An array of directories specifying the lookup path for the \verb+include+ and \verb+open+ directives (see * Section~\ref{section:include}). * The default value is an array of two elements --- \verb+.+ and \verb+$(STDLIB)+. * \var{OSTYPE} * Set to the machine architecture \Prog{omake} is running on. Possible values are * \verb+Unix+ (for all Unix versions, including Linux and Mac OS X), \verb+Win32+ * (for MS-Windows, \OMake{} compiled with MSVC++ or Mingw), and \verb+Cygwin+ (for * MS-Windows, \OMake{} compiled with Cygwin). * \var{CCOMPTYPE} * Set to to either "cc" when the C compiler is invoked in Unix style, * or "msvc" for Microsoft Visual C (actually, this is the \verb+ccomp_type+ * variable of \verb+ocamlc -config+). This setting is considered as a system * preference. * \var{SYSNAME} * The name of the operating system for the current machine. * \var{NODENAME} * The hostname of the current machine. * \varlabel{OS_VERSION}{OS\_VERSION} * The operating system release. * \var{MACHINE} * The machine architecture, e.g.\ \verb+i386+, \verb+sparc+, etc. * \var{HOST} * Same as \verb+NODENAME+. * \var{USER} * The login name of the user executing the process. * \var{HOME} * The home directory of the user executing the process. * \var{PID} * The \OMake{} process id. * \var{TARGETS} * The command-line target strings. For example, if \OMake{} is invoked with the * following command line, * \begin{verbatim} * omake CFLAGS=1 foo bar.c * \end{verbatim} * * then \verb+TARGETS+ is defined as \verb+foo bar.c+. * * \varlabel{BUILD_SUMMARY}{BUILD\_SUMMARY} * The \verb+BUILD_SUMMARY+ variable refers to the file that \verb+omake+ uses * to summarize a build (the message that is printed at the very end of a build). * The file is empty when the build starts. If you wish to add additional messages * to the build summary, you can edit/modify this file during the build. * * For example, if you want to point out that some action was taken, * you can append a message to the build summary. * * \begin{verbatim} * foo: boo * echo "The file foo was built" >> $(BUILD_SUMMARY) * ...build foo... * \end{verbatim} * * \var{VERBOSE} * Whether certain commands should be verbose. A boolean flag that is \verb+false+ * by default and is set to \verb+true+ when \OMake{} is invoked with the * \verb+--verbose+ option. * \end{doc} *) (************************************************************************ * Negate a boolean. * * \begin{doc} * \section{Logic, Boolean functions, and control flow} * \label{section:logic} * * Boolean values in omake are represented by case-insensitive strings. The * \emph{false} value can be represented by the strings \verb+false+, \verb+no+, * \verb+nil+, \verb+undefined+ or \verb+0+, and everything else is true. * * \fun{not} * * \begin{verbatim} * $(not e) : String * e : String * \end{verbatim} * * The \verb+not+ function negates a Boolean value. * * For example, \verb+$(not false)+ expands to the string \verb+true+, and * \verb+$(not hello world)+ expands to \verb+false+. * \end{doc} *) let not_fun venv pos loc args = let pos = string_pos "not" pos in match args with [s] -> Omake_builtin_util.val_of_bool(not (Omake_eval.bool_of_value venv pos s)) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Check if two values are equal. * * \begin{doc} * \fun{equal} * * \begin{verbatim} * $(equal e1, e2) : String * e1 : String * e2 : String * \end{verbatim} * * The \verb+equal+ function tests for equality of two values. This is * defined for anything that can be expanded to a string and for arrays. * * For example \verb+$(equal a, b)+ expands to \verb+false+, and \verb+$(equal hello world, hello world)+ expands to \verb+true+. * \end{doc} *) let rec is_equal venv pos v1 v2 = let open Omake_value_type in match v1, v2 with | ValNone, ValNone -> true | (ValSequence _ | ValQuote _ | ValQuoteString _ | ValInt _ | ValFloat _ | ValData _ | ValWhite _ | ValString _ | ValDir _ | ValNode _), (ValSequence _ | ValQuote _ | ValQuoteString _ | ValInt _ | ValFloat _ | ValData _ | ValWhite _ | ValString _ | ValDir _ | ValNode _) -> (* this is string equality *) Omake_eval.string_of_value venv pos v1 = Omake_eval.string_of_value venv pos v2 | ValArray _, _ | _, ValArray _ -> (* the arrays need to be flattened first *) let a1 = Omake_eval.values_of_value venv pos v1 in let a2 = Omake_eval.values_of_value venv pos v2 in List.length a1 = List.length a2 && List.for_all2 (is_equal venv pos) a1 a2 | _ -> false let equal venv pos loc args = let _pos = string_pos "equal" pos in match args with | [v1; v2] -> let v1 = Omake_eval.eval_value venv pos v1 in let v2 = Omake_eval.eval_value venv pos v2 in Omake_builtin_util.val_of_bool (is_equal venv pos v1 v2) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Conjunction. * * \begin{doc} * \fun{and} * * \begin{verbatim} * $(and e1, ..., en) : String * e1, ..., en: Sequence * \end{verbatim} * * The \verb+and+ function evaluates to the conjunction of its arguments. * * For example, in the following code, \verb+X+ is true, and \verb+Y+ is false. * * \begin{verbatim} * A = a * B = b * X = $(and $(equal $(A), a) true $(equal $(B), b)) * Y = $(and $(equal $(A), a) true $(equal $(A), $(B))) * \end{verbatim} * \end{doc} *) let and_fun venv pos _ args = let pos = string_pos "and" pos in Omake_builtin_util.val_of_bool (**) (List.for_all (fun arg -> List.for_all (Omake_eval.bool_of_value venv pos) (Omake_eval.values_of_value venv pos arg)) args) (* * Disjunction. * * \begin{doc} * \fun{or} * * \begin{verbatim} * $(or e1, ..., en) : String * e1, ..., en: String Sequence * \end{verbatim} * * The \verb+or+ function evaluates to the disjunction of its arguments. * * For example, in the following code, \verb+X+ is true, and \verb+Y+ is false. * * \begin{verbatim} * A = a * B = b * X = $(or $(equal $(A), a) false $(equal $(A), $(B))) * Y = $(or $(equal $(A), $(B)) $(equal $(A), b)) * \end{verbatim} * \end{doc} *) let or_fun venv pos _ args = let pos = string_pos "or" pos in Omake_builtin_util.val_of_bool (**) (List.exists (fun arg -> List.exists (Omake_eval.bool_of_value venv pos) (Omake_eval.values_of_value venv pos arg)) args) (* * Conditionals. * The values are computed lazily. * * \begin{doc} * \form{if}\index{elseif}\index{else} * * \begin{verbatim} * $(if e1, e2[, e3]) : value * e1 : String * e2, e3 : value * \end{verbatim} * * The \verb+if+ function represents a conditional based on a Boolean value. * For example \verb+$(if $(equal a, b), c, d)+ evaluates to \verb+d+. * * Conditionals may also be declared with an alternate syntax. * * \begin{verbatim} * if e1 * body1 * elseif e2 * body2 * ... * else * bodyn * \end{verbatim} * * If the expression \verb+e1+ is not false, then the expressions in \verb+body1+ * are evaluated and the result is returned as the value of the conditional. Otherwise, * if \verb+e1+ evaluates to false, the evaluation continues with the \verb+e2+ * expression. If none of the conditional expressions is true, then the expressions * in \verb+bodyn+ are evaluated and the result is returned as the value * of the conditional. * * There can be any number of \verb+elseif+ clauses; the \verb+else+ clause is * optional. * * Note that each branch of the conditional defines its own scope, so variables * defined in the branches are normally not visible outside the conditional. * The \verb+export+ command may be used to export the variables defined in * a scope. For example, the following expression represents a common idiom * for defining the C compiler configuration. * * \begin{verbatim} * if $(equal $(OSTYPE), Win32) * CC = cl * CFLAGS += /DWIN32 * export * else * CC = gcc * CFLAGS += -g -O2 * export * \end{verbatim} * \end{doc} *) let empty_val : Omake_value_type.t = ValSequence [] (* GS. Note that this is only the implementation for $(if ...), not for the multiline-if (which is in Omake_eval). *) let if_fun venv pos loc args = let pos = string_pos "if" pos in let test, v1, v2 = match args with [test; v1; v2] -> test, v1, v2 | [test; v1] -> test, v1, empty_val | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (2, 3), List.length args))) in (* The args are lazily evaluated (there is a ValStringExp around them). Force the evaluation of the selected case. *) Omake_eval.eval_value venv pos (if Omake_eval.bool_of_value venv pos test then v1 else v2 ) (* * Match command. * * \begin{doc} * \twofuns{switch}{match}\index{case}\index{default} * * The \verb+switch+ and \verb+match+ functions perform pattern matching. * * \verb+$(switch , , , ..., , )+ * \verb+$(match , , , ..., , )+ * * The number of \verb+/+ pairs is arbitrary. They strictly * alternate; the total number of arguments to \verb++ must be odd. * * The \verb++ is evaluated to a string, and compared with \verb++. * If it matches, the result of the expression is \verb++. Otherwise * evaluation continues with the remaining patterns until a match is found. * If no pattern matches, the value is the empty string. * * The \verb+switch+ function uses string comparison to compare * the argument with the patterns. For example, the following * expression defines the \verb+FILE+ variable to be either * \verb+foo+, \verb+bar+, or the empty string, depending * on the value of the \verb+OSTYPE+ variable. * * \begin{verbatim} * FILE = $(switch $(OSTYPE), Win32, foo, Unix, bar) * \end{verbatim} * * The \verb+match+ function uses regular expression patterns (see the * \verb+grep+ function). If a match is found, the variables * \verb+$1, $2, ...+ are bound to the substrings matched between * \verb+\(+ and \verb+\)+ delimiters. * The \verb+$0+ variable contains the entire match, and \verb+$*+ * is an array of the matched substrings. * to the matched substrings. * * \begin{verbatim} * FILE = $(match foo_xyz/bar.a, foo_\\\(.*\\\)/\\\(.*\\\)\.a, foo_$2/$1.o) * \end{verbatim} * * The \verb+switch+ and \verb+match+ functions also have an alternate (more usable) * form. * * \begin{verbatim} * match e * case pattern1 * body1 * case pattern2 * body2 * ... * default * bodyd * \end{verbatim} * * If the value of expression \verb+e+ matches \verb+pattern_i+ and no previous pattern, * then \verb+body_i+ is evaluated and returned as the result of the \verb+match+. * The \verb+switch+ function uses string comparison; the \verb+match+ function * uses regular expression matching. * * \begin{verbatim} * match $(FILE) * case $".*\(\.[^\/.]*\)" * println(The string $(FILE) has suffix $1) * default * println(The string $(FILE) has no suffix) * \end{verbatim} * \end{doc} *) (* * String pattern matching. *) let rec eval_match_cases1 compare venv pos loc s cases = match cases with (v, pattern, el, export) :: cases -> if Lm_symbol.eq v Omake_symbol.case_sym then let pattern = Omake_eval.string_of_value venv pos pattern in match compare venv pos loc pattern s with | Some venv -> Omake_eval.eval_sequence_export_exp venv pos el export | None -> eval_match_cases1 compare venv pos loc s cases else if Lm_symbol.eq v Omake_symbol.default_sym then Omake_eval.eval_sequence_export_exp venv pos el export else raise (Omake_value_type.OmakeException (loc_pos loc pos, StringVarError ("unknown case", v))) | [] -> venv, ValNone let rec eval_match_cases2 compare venv pos loc s cases = match cases with | pattern :: e :: cases -> let pattern = Omake_eval.string_of_value venv pos pattern in (match compare venv pos loc pattern s with Some venv -> Omake_eval.eval_body_exp venv pos ValNone e | None -> eval_match_cases2 compare venv pos loc s cases) | [v] -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringValueError ("match requires an odd number of arguments", v))) | [] -> venv, ValNone let eval_match_exp compare venv pos loc (args : Omake_value_type.t list) kargs = let pos = string_pos "eval_match_exp" pos in match args, kargs with [cases; arg], [] -> (match Omake_eval.eval_value venv pos cases with ValCases cases -> let s = Omake_eval.string_of_value venv pos arg in eval_match_cases1 compare venv pos loc s cases | _ -> raise (Omake_value_type.OmakeException (pos, StringError "malformed match expression"))) | arg :: rest, [] -> let s = Omake_eval.string_of_value venv pos arg in eval_match_cases2 compare venv pos loc s rest | [], [] -> venv, ValNone | _, _ :: _ -> raise (Omake_value_type.OmakeException (pos, StringError "illegal keyword arguments")) let switch_fun = let compare venv _ _ s1 s2 = if s1 = s2 then Some venv else None in eval_match_exp compare let match_fun = let compare venv pos loc (s1 : string) s2 = let lex = try Omake_lexer.lexer_of_string s1 with Failure err -> let msg = Format.sprintf "Malformed regular expression '%s'" s1 in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError (msg, err))) in let channel = Lm_channel.of_string s2 in match Omake_lexer.Lexer.search lex channel with | Some (_, _, _, matched, args) -> Some (Omake_env.venv_add_match venv matched args) | None -> None in eval_match_exp compare (* * \begin{doc} * \form{try} * * \begin{verbatim} * try * try-body * catch class1(v1) * catch-body * when expr * when-body * ... * finally * finally-body * \end{verbatim} * * The \verb+try+ form is used for exception handling. * First, the expressions in the \verb+try-body+ are evaluated. * * If evaluation results in a value \verb+v+ without raising an * exception, then the expressions in the \verb+finally-body+ * are evaluated and the value \verb+v+ is returned as the result. * * If evaluation of the \verb+try-body+ results in a exception object \verb+obj+, * the \verb+catch+ clauses are examined in order. When examining \verb+catch+ * clause \verb+catch class(v)+, if the exception object \verb+obj+ * is an instance of the class name \verb+class+, the variable \verb+v+ is bound * to the exception object, and the expressions in the \verb+catch-body+ * are evaluated. * * If a \verb+when+ clause is encountered while a \verb+catch+ body is being evaluated, * the predicate \verb+expr+ is evaluated. If the result is true, evaluation continues * with the expressions in the \verb+when-body+. Otherwise, the next \verb+catch+ * clause is considered for evaluation. * * If evaluation of a \verb+catch-body+ or \verb+when-body+ completes successfully, * returning a value \verb+v+, without encountering another \verb+when+ clause, * then the expressions in the \verb+finally-body+ * are evaluated and the value \verb+v+ is returned as the result. * * There can be any number of \verb+catch+ clauses; the \verb+finally+ clause * is optional. * \end{doc} *) (* * Temporary type for evaluating try blocks. *) type try_exp = | TrySuccessExp of (Omake_env.t * Omake_value_type.t) | TryFailureExp of Omake_value_type.pos * Omake_value_type.obj * exn (* * Build an object from an Omake_value_type.OmakeException. * The default object is RuntimeException. *) let object_of_omake_exception venv pos exp = let pos = pp_print_pos Format.str_formatter pos; Format.flush_str_formatter () in let exp = Omake_value_print.pp_print_exn Format.str_formatter exp; Format.flush_str_formatter () in let obj = Omake_env.venv_find_object_or_empty venv Omake_var.runtime_exception_var in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.pos_sym (ValString pos) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.message_sym (ValString exp) in let obj = Omake_env.venv_add_class obj Omake_symbol.runtime_exception_sym in obj (* * Build an object from an Omake_value_type.OmakeException. * The default object is RuntimeException. *) let object_of_uncaught_exception venv pos exn = let pos = pp_print_pos Format.str_formatter pos; Format.flush_str_formatter () in let obj = Omake_env.venv_find_object_or_empty venv Omake_var.runtime_exception_var in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.pos_sym (ValString pos) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.message_sym (ValString (Printexc.to_string exn)) in let obj = Omake_env.venv_add_class obj Omake_symbol.runtime_exception_sym in obj (* * Exception handling. *) let rec eval_finally_case venv pos result cases = match cases with | (v, _, e, export) :: _ when Lm_symbol.eq v Omake_symbol.finally_sym -> Omake_eval.eval_sequence_export venv pos result e export | _ :: cases -> eval_finally_case venv pos result cases | [] -> venv, result (* * We have successfully evaluated a CatchCase. * Search for the following WhenCases. * If a WhenCase fails, go to the following catch case. *) let rec eval_catch_rest venv pos obj result cases = match cases with (v, s, e, export) :: cases when Lm_symbol.eq v Omake_symbol.when_sym -> let b = Omake_eval.bool_of_value venv pos s in if b then let venv, result = Omake_eval.eval_sequence_export venv pos result e export in eval_catch_rest venv pos obj result cases else eval_exception venv pos obj cases | _ -> Some (venv, result) and eval_catch_case venv pos v obj e cases export = let venv = Omake_env.venv_add_var venv v (ValObject obj) in let venv, result = Omake_eval.eval_sequence_export_exp venv pos e export in eval_catch_rest venv pos obj result cases (* * Find the first CatchCase that matches the object, * and evaluate it. Do not evaluate the finally case. *) and eval_exception venv pos obj cases = match cases with (v, s, e, export) :: cases -> if Lm_symbol.eq v Omake_symbol.when_sym then eval_exception venv pos obj cases else if Lm_symbol.eq v Omake_symbol.finally_sym then None else if Lm_symbol.eq v Omake_symbol.default_sym || Omake_env.venv_instanceof obj v then (* FIXME: BUG: JYH: this binding occurence should be fixed *) let v = Omake_ir.VarThis (loc_of_pos pos, Lm_symbol.add (Omake_eval.string_of_value venv pos s)) in eval_catch_case venv pos v obj e cases export else eval_exception venv pos obj cases | [] -> None (* * The try block is a little complicated because of the finally * case. Note that if an exception occurs in a CatchCase, the * FinallyCase *still* needs to be evaluated. *) let try_fun venv pos loc args kargs = let pos = string_pos "eval_try_exp" pos in let cases, e = match args, kargs with [cases; e], [] -> (match Omake_eval.eval_value venv pos cases with ValCases cases -> cases, e | _ -> raise (Omake_value_type.OmakeException (pos, StringError "malformed try expression"))) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in let e = try let result = Omake_eval.eval_body_exp venv pos ValNone e in TrySuccessExp result with Omake_value_type.OmakeException (pos, exp) as exn -> TryFailureExp (pos, object_of_omake_exception venv pos exp, exn) | Omake_value_type.UncaughtException (pos, exn) -> TryFailureExp (pos, object_of_uncaught_exception venv pos exn, exn) | Omake_value_type.RaiseException (pos, obj) as exn -> TryFailureExp (pos, obj, exn) | Omake_value_type.Return _ | Omake_env.Break _ as exn -> TryFailureExp (pos, object_of_uncaught_exception venv pos exn, exn) in let e = match e with TryFailureExp (pos, obj, _) -> (try match eval_exception venv pos obj cases with Some result -> TrySuccessExp result | None -> e with Omake_value_type.OmakeException (pos, exp) as exn -> TryFailureExp (pos, object_of_omake_exception venv pos exp, exn) | Omake_value_type.UncaughtException (pos, exn) -> TryFailureExp (pos, object_of_uncaught_exception venv pos exn, exn) | Omake_value_type.RaiseException (pos, obj) as exn -> TryFailureExp (pos, obj, exn)) | TrySuccessExp _ -> e in match e with TrySuccessExp ((venv, result)) -> eval_finally_case venv pos result cases | TryFailureExp (_, _, exn) -> ignore (eval_finally_case venv pos ValNone cases); raise exn (* * Raise an exception. * * \begin{doc} * \form{raise} * * \begin{verbatim} * raise exn * exn : Exception * \end{verbatim} * * The \verb+raise+ function raises an exception. * The \verb+exn+ object can be any object. However, * the normal convention is to raise an \hyperobj{Exception}. * * If the exception is never caught, the whole object will be verbosely * printed in the error message. However, if the object is an \verb+Exception+ one * and contains a \verb+message+ field, only that field will be included in the * error message. * \end{doc} *) let raise_fun venv pos loc args = let pos = string_pos "raise" pos in match args with | [arg] -> let obj = Omake_eval.eval_value venv pos arg in let obj = Omake_eval.eval_object venv pos obj in raise (Omake_value_type.RaiseException (pos, obj)) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Exit the program. * * \begin{doc} * \fun{exit} * * \begin{verbatim} * exit(code) * code : Int * \end{verbatim} * * The \verb+exit+ function terminates \Prog{omake} abnormally. * * \verb+$(exit )+ * * The \verb+exit+ function takes one integer argument, which is exit code. * Non-zero values indicate abnormal termination. * \end{doc} *) let exit_aux f venv pos loc args = let pos = string_pos "exit" pos in let code = flush stdout; flush stderr; match args with [] -> 0 | [s] -> (match Omake_eval.values_of_value venv pos s with [_] -> Omake_value.int_of_value venv pos s | [] -> 0 | args -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args)))) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in f loc pos code let exit_fun = exit_aux (fun loc pos code -> raise (Omake_value_type.ExitException (loc_pos loc pos, code))) let exit_parent_fun = exit_aux (fun loc pos code -> raise (Omake_value_type.ExitParentException (loc_pos loc pos, code))) (* * Check whether a variable is defined. * * \begin{doc} * \fun{defined} * * \begin{verbatim} * $(defined sequence) : String * sequence : Sequence * \end{verbatim} * * The \verb+defined+ function test whether all the variables in the sequence are * currently defined. For example, the following code defines the \verb+X+ variable * if it is not already defined. * * \begin{verbatim} * if $(not $(defined X)) * X = a b c * export * \end{verbatim} * * It is acceptable to use qualified names. * * \begin{verbatim} * $(defined X.a.b) * $(defined public.X) * \end{verbatim} * \end{doc} *) let defined venv pos loc args = let pos = string_pos "defined" pos in match args with [arg] -> let args = Omake_eval.strings_of_value venv pos arg in let b = List.for_all (fun s -> Omake_builtin_util.defined_sym venv pos loc s) args in if b then Omake_builtin_util.val_true else Omake_builtin_util.val_false | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{defined-env} * * \begin{verbatim} * $(defined-env sequence) : String * sequence : String * \end{verbatim} * * The \verb+defined-env+ function tests whether a variable is defined * as part of the process environment. * * For example, the following code adds the \verb+-g+ compile * option if the environment variable \verb+DEBUG+ is defined. * * \begin{verbatim} * if $(defined-env DEBUG) * CFLAGS += -g * export * \end{verbatim} * \end{doc} *) let defined_env venv pos loc args = let pos = string_pos "defined-env" pos in match args with | [arg] -> let args = Omake_eval.strings_of_value venv pos arg in let b = List.for_all (fun s -> Omake_env.venv_defined_env venv (Lm_symbol.add s)) args in Omake_builtin_util.val_of_bool b | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Get a variable from the environment. * * \begin{doc} * \fun{getenv} * * \begin{verbatim} * $(getenv name) : String * $(getenv name, default) : String * \end{verbatim} * * The \verb+getenv+ function gets the value of a variable from * the process environment. The function takes one or two arguments. * * In the single argument form, an exception is raised if the variable * variable is not defined in the environment. In the two-argument form, * the second argument is returned as the result if the value is not * defined. * * For example, the following code defines the variable \verb+X+ * to be a space-separated list of elements of the \verb+PATH+ * environment variable if it is defined, and to \verb+/bin /usr/bin+ * otherwise. * * \begin{verbatim} * X = $(split $(PATHSEP), $(getenv PATH, /bin:/usr/bin)) * \end{verbatim} * * You may also use the alternate form. * \begin{verbatim} * getenv(NAME) * default * \end{verbatim} * \end{doc} *) let getenv venv pos loc (args : Omake_value_type.t list) : Omake_value_type.t = let pos = string_pos "getenv" pos in let arg, def = match args with | [arg] -> arg, None | [(ValBody _) as def; arg] | [arg; def] -> arg, Some def | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let s = Omake_eval.string_of_value venv pos arg in try ValString (Omake_env.venv_getenv venv (Lm_symbol.add s)) with Not_found -> match def with | Some def -> Omake_eval.eval_body_value venv pos def | None -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("undefined environment variable", s))) (* * \begin{doc} * \fun{setenv} * * \begin{verbatim} * setenv(name, value) * name : String * value : String * \end{verbatim} * * The \verb+setenv+ function sets the value of a variable in * the process environment. Environment variables are scoped * like normal variables. * * \end{doc} *) let setenv venv pos loc args kargs = let pos = string_pos "setenv" pos in match args, kargs with | [arg1; arg2], [] -> let v = Omake_eval.string_of_value venv pos arg1 in let s = Omake_eval.string_of_value venv pos arg2 in let venv = Omake_env.venv_setenv venv (Lm_symbol.add v) s in venv, Omake_value_type.ValData s | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * \begin{doc} * \fun{unsetenv} * * \begin{verbatim} * unsetenv(names) * names : String Array * \end{verbatim} * * The \verb+unsetenv+ function removes some variable definitions from * the process environment. Environment variables are scoped * like normal variables. * * \end{doc} *) let unsetenv venv pos loc args kargs = let pos = string_pos "unsetenv" pos in match args, kargs with | [arg], [] -> let vars = Omake_eval.strings_of_value venv pos arg in let venv = List.fold_left (fun venv v -> Omake_env.venv_unsetenv venv (Lm_symbol.add v)) venv vars in venv, Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{get-registry} * * \begin{verbatim} * get-registry(hkey, key, field) : String * get-registry(hkey, key, field, default) : String * hkey : String * key : String * field : String * \end{verbatim} * * The \verb+get-registry+ function retrieves a string value from the * system registry on Win32. On other architectures, there is no * registry. * * The \verb+hive+ (I think that is the right word), indicates which part * of the registry to use. It should be one of the following values. * * \begin{itemize} * \item \verb+HKEY_CLASSES_ROOT+ * \item \verb+HKEY_CURRENT_CONFIG+ * \item \verb+HKEY_CURRENT_USER+ * \item \verb+HKEY_LOCAL_MACHINE+ * \item \verb+HKEY_USERS+ * \end{itemize} * Refer to the Microsoft documentation if you want to know what these mean. * * The \verb+key+ is the field you want to get from the registry. * It should have a form like \verb+A\B\C+ (if you use forward slashes, they will * be converted to backslashes). The field is the sub-field of the key. * * In the 4-argument form, the \verb+default+ is returned on failure. * You may also use the alternate form. * * \begin{verbatim} * get-registry(hkey, key, field) * default * \end{verbatim} * * \end{doc} *) let get_registry venv pos loc (args : Omake_value_type.t list) : Omake_value_type.t = let pos = string_pos "get-registry" pos in let hkey, key, field, def = match args with | [hkey; key; field] -> hkey, key, field, None | [(ValBody _) as def; hkey; key; field] | [hkey; key; field; def] -> hkey, key, field, Some def | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (3, 4), List.length args))) in let hkey = String.uppercase_ascii (Omake_eval.string_of_value venv pos hkey) in let hkey_code = match hkey with | "HKEY_CLASSES_ROOT" -> Lm_unix_util.HKEY_CLASSES_ROOT | "HKEY_CURRENT_CONFIG" -> Lm_unix_util.HKEY_CURRENT_CONFIG | "HKEY_CURRENT_USER" -> Lm_unix_util.HKEY_CURRENT_USER | "HKEY_LOCAL_MACHINE" -> Lm_unix_util.HKEY_LOCAL_MACHINE | "HKEY_USERS" -> Lm_unix_util.HKEY_USERS | s -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("unknown hkey", s))) in let key = Bytes.of_string (Omake_eval.string_of_value venv pos key) in let () = for i = 0 to Bytes.length key - 1 do if Bytes.get key i = '/' then Bytes.set key i '\\' done in let key = Bytes.to_string key in let field = Omake_eval.string_of_value venv pos field in try ValString (Lm_unix_util.registry_find hkey_code key field) with Not_found -> match def with | Some def -> Omake_eval.eval_body_value venv pos def | None -> let s = Printf.sprintf "%s\\%s\\%s" hkey key field in raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("key not found", s))) (* * Get a variable from the environment. * * \begin{doc} * \fun{getvar} * * \begin{verbatim} * $(getvar name) : String * \end{verbatim} * * The \verb+getvar+ function gets the value of a variable. * * An exception is raised if the variable * variable is not defined. * * For example, the following code defines X to be the string abc. * * \begin{verbatim} * NAME = foo * foo_1 = abc * X = $(getvar $(NAME)_1) * \end{verbatim} * * It is acceptable to use qualified names. * * \begin{verbatim} * $(getvar X.a.b) * \end{verbatim} * \end{doc} *) let getvar venv pos loc args = let pos = string_pos "getvar" pos in match args with | [arg] -> Omake_builtin_util.get_sym venv pos loc (Omake_eval.string_of_value venv pos arg) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{setvar} * * \begin{verbatim} * setvar(name, value) * name : String * value : String * \end{verbatim} * * The \verb+setvar+ function defines a new variable. For example, the * following code defines the variable \verb+X+ to be the string \verb+abc+. * * \begin{verbatim} * NAME = X * setvar($(NAME), abc) * \end{verbatim} * * It is acceptable to use qualified names. * * \begin{verbatim} * setvar(public.X, abc) * \end{verbatim} * \end{doc} *) let setvar venv pos loc args kargs = let pos = string_pos "setvar" pos in match args, kargs with | [arg1; arg2], [] -> let s = Omake_eval.string_of_value venv pos arg1 in let venv = Omake_builtin_util.add_sym venv pos loc s arg2 in venv, arg2 | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (************************************************************************ * Arrays. * * \begin{doc} * \section{Arrays and sequences} * * \fun{array} * * \begin{verbatim} * $(array elements) : Array * elements : Sequence * \end{verbatim} * * The \verb+array+ function creates an array from a sequence. * If the \verb++ is a string, the elements of the array * are the whitespace-separated elements of the string, respecting * quotes. * * In addition, array variables can be declared as follows. * * \begin{verbatim} * A[] = * * ... * * \end{verbatim} * * In this case, the elements of the array are exactly * \verb++, ..., \verb++, and whitespace is * preserved literally. * \end{doc} *) let array_fun venv pos _ args : Omake_value_type.t = let pos = string_pos "array" pos in let args = List.fold_left (fun args arg -> let args' = Omake_eval.values_of_value venv pos arg in List.rev_append args' args) [] args in ValArray (List.rev args) (* * Concatenate the strings with a separator. * * \begin{doc} * \fun{split} * * \begin{verbatim} * $(split sep, elements) : Array * sep : String * elements : Sequence * \end{verbatim} * * The \verb+split+ function takes two arguments, a string of separators, and * a string argument. The result is an array of elements determined by * splitting the elements by all occurrence of the separator in the * \verb+elements+ sequence. * * For example, in the following code, the \verb+X+ variable is * defined to be the array \verb+/bin /usr/bin /usr/local/bin+. * * \begin{verbatim} * PATH = /bin:/usr/bin:/usr/local/bin * X = $(split :, $(PATH)) * \end{verbatim} * * The \verb+sep+ argument may be omitted. In this case \verb+split+ breaks its * arguments along the white space. Quotations are not split. * \end{doc} *) let split_fun venv pos loc args = let pos = string_pos "split" pos in let strings = match args with [arg] -> let args = Omake_eval.strings_of_value venv pos arg in let args = List.fold_left (fun args s -> List.rev_append (Lm_string_util.tokens_std s) args) [] args in List.rev args | [sep; arg] -> let sep = Omake_eval.string_of_value venv pos sep in let args = Omake_eval.strings_of_value venv pos arg in let args = List.fold_left (fun args s -> List.rev_append (Lm_string_util.split sep s) args) [] args in List.rev args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in Omake_value.concat_strings strings (* * Concatenate the strings with a separator. * * \begin{doc} * \fun{concat} * * \begin{verbatim} * $(concat sep, elements) : String * sep : String * elements : Sequence * \end{verbatim} * * The \verb+concat+ function takes two arguments, a separator string, and * a sequence of elements. The result is a string formed by concatenating * the elements, placing the separator between adjacent elements. * * For example, in the following code, the \verb+X+ variable is * defined to be the string \verb+foo_x_bar_x_baz+. * * \begin{verbatim} * X = foo bar baz * Y = $(concat _x_, $(X)) * \end{verbatim} * \end{doc} *) let concat_fun venv pos loc args : Omake_value_type.t = let pos = string_pos "concat" pos in match args with |[sep; arg] -> let sep = Omake_eval.string_of_value venv pos sep in let args = Omake_eval.strings_of_value venv pos arg in ValData (String.concat sep args) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Length of a list. * * \begin{doc} * \fun{length} * * \begin{verbatim} * $(length sequence) : Int * sequence : Sequence * \end{verbatim} * * The \verb+length+ function returns the number of elements in its argument. * * For example, the expression \verb+$(length a b "c d")+ evaluates to 3. * \end{doc} *) let length_fun venv pos loc args : Omake_value_type.t = let pos = string_pos "length" pos in match args with | [arg] -> let args = Omake_eval.values_of_value venv pos arg in ValInt (List.length args) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Get the nth element of a list. * * \begin{doc} * \fun{nth} * * \begin{verbatim} * $(nth i, sequence) : value * i : Int * sequence : Sequence * raises RuntimeException * \end{verbatim} * * The \verb+nth+ function returns the nth element of its argument, treated as * a list. Counting starts at 0. An exception is raised if the index is not in bounds. * * For example, the expression \verb+$(nth 1, a "b c" d)+ evaluates to \verb+"b c"+. * * \fun{replace-nth} * * \begin{verbatim} * $(replace-nth i, sequence, x) : value * i : Int * sequence : Sequence * x : value * raises RuntimeException * \end{verbatim} * * The \verb+replace-nth+ function replaces the nth element of its argument with a new * value \verb+x+. Counting starts at 0. An exception is raised if the index is not in bounds. * * For example, the expression \verb+$(replace-nth 1, a "b c" d, x)+ evaluates to \verb+a x d+. * \end{doc} *) let nth_fun venv pos loc args = let pos = string_pos "nth" pos in match args with [i; arg] -> let i = Omake_value.int_of_value venv pos i in let args = Omake_eval.values_of_value venv pos arg in let len = List.length args in if i < 0 || i >= len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("nth: index is out of bounds", i))); List.nth args i | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let replace_nth_fun venv pos loc args = let pos = string_pos "replace-nth" pos in match args with [i; arg; x] -> let i = Omake_value.int_of_value venv pos i in let args = Omake_eval.values_of_value venv pos arg in let len = List.length args in if i < 0 || i >= len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("replace-nth: index is out of bounds", i))); Omake_value.concat_array (Lm_list_util.replace_nth i x args) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Get a subrange of a list. * * \begin{doc} * \fun{nth-hd} * * \begin{verbatim} * $(nth-hd i, sequence) : value * i : Int * sequence : Sequence * raises RuntimeException * \end{verbatim} * * The \verb+nth-hd+ function returns the first \verb+i+ elements of * the sequence. An exception is raised if the sequence is not * at least \verb+i+ elements long. * * For example, the expression \verb+$(nth-hd 2, a "b c" d)+ evaluates to \verb+a "b c"+. * * \fun{nth-tl} * * \begin{verbatim} * $(nth-tl i, sequence) : value * i : Int * sequence : Sequence * raises RuntimeException * \end{verbatim} * * The \verb+nth-tl+ function skips \verb+i+ elements of the sequence * and returns the rest. An exception is raised if the sequence is not * at least \verb+i+ elements long. * * For example, the expression \verb+$(nth-tl 1, a "b c" d)+ evaluates to \verb+"b c" d+. * * \fun{subrange} * * \begin{verbatim} * $(subrange off, len, sequence) : value * off : Int * len : Int * sequence : Sequence * raises RuntimeException * \end{verbatim} * * The \verb+subrange+ function returns a subrange of the sequence. * Counting starts at 0. An exception is raised if the specified * range is not in bounds. * * For example, the expression \verb+$(subrange 1, 2, a "b c" d e)+ evaluates to \verb+"b c" d+. * \end{doc} *) let rec nth_hd l_rev l i = if i = 0 then List.rev l_rev else match l with h :: l -> nth_hd (h :: l_rev) l (pred i) | [] -> raise (Invalid_argument "nth_hd") let rec nth_tl l i = if i = 0 then l else match l with _ :: l -> nth_tl l (pred i) | [] -> raise (Invalid_argument "nth_tl") let sub l off len = nth_hd [] (nth_tl l off) len let nth_hd_fun venv pos loc args : Omake_value_type.t = let pos = string_pos "nth-hd" pos in match args with | [i; arg] -> let i = Omake_value.int_of_value venv pos i in let args = Omake_eval.values_of_value venv pos arg in let len = List.length args in if i < 0 || i > len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("nth-hd: index is out of bounds", i))); ValArray (nth_hd [] args i) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let nth_tl_fun venv pos loc args : Omake_value_type.t = let pos = string_pos "nth-tl" pos in match args with | [i; arg] -> let i = Omake_value.int_of_value venv pos i in let args = Omake_eval.values_of_value venv pos arg in let len = List.length args in if i < 0 || i > len then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("nth-tl: index is out of bounds", i))); ValArray (nth_tl args i) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let subrange_fun venv pos loc args : Omake_value_type.t = let pos = string_pos "subrange" pos in match args with [off; len; arg] -> let off = Omake_value.int_of_value venv pos off in let len = Omake_value.int_of_value venv pos len in let args = Omake_eval.values_of_value venv pos arg in let alen = List.length args in if off < 0 || len < 0 || off + len > alen then raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("one or more indexes are out of bounds", off + len))); ValArray (sub args off len) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 3, List.length args))) (* * Reverse a list. * * \begin{doc} * \fun{rev} * * \begin{verbatim} * $(rev sequence) : Sequence * sequence : Sequence * \end{verbatim} * * The \verb+rev+ function returns the elements of a sequence in reverse order. * For example, the expression \verb+$(rev a "b c" d)+ evaluates to \verb+d "b c" a+. * \end{doc} *) let rev_fun venv pos loc args : Omake_value_type.t = let pos = string_pos "rev" pos in match args with | [arg] -> let args = Omake_eval.values_of_value venv pos arg in ValArray (List.rev args) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{join} * * \begin{verbatim} * $(join sequence1, sequence2) : Sequence * sequence1 : Sequence * sequence2 : Sequence * \end{verbatim} * * The \verb+join+ function joins together the elements of the two sequences. For example, * \verb+$(join a b c, .c .cpp .h)+ evaluates to \verb+a.c b.cpp c.h+. If the two input * sequences have different lengths, the remainder of the longer sequence is copied at the end * of the output unmodified. * \end{doc} * * The function is implemented in Pervasives.om, but it's more appropriate to documment it here. *) (* * \begin{doc} * \fun{string} * * \begin{verbatim} * $(string sequence) : String * sequence : Sequence * \end{verbatim} * * The \verb+string+ function flattens a sequence into a single string. * This is similar to the \verb+concat+ function, but the elements are * separated by whitespace. The result is treated as a unit; whitespace * is significant. * \end{doc} *) let string venv pos loc args : Omake_value_type.t = let pos = string_pos "string" pos in match args with | [arg] -> let args = Omake_eval.strings_of_value venv pos arg in let s = String.concat " " args in ValData s | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{string-length} * * \begin{verbatim} * $(string-length sequence) : Int * sequence : Sequence * \end{verbatim} * * The \verb+string-lenght+ returns a length (number of characters) in * its argument. If the argument is a sequence, it flattens it, so \verb+$(string-length sequence)+ * is equivalent to \verb+$(string-length $(string sequence))+. * \end{doc} *) let string_length venv pos loc args : Omake_value_type.t = let pos = string_pos "string-length" pos in match args with | [arg] -> let args = Omake_eval.strings_of_value venv pos arg in let len = if args = [] then 0 else List.fold_left (fun i s -> i + 1 + String.length s) (-1) args in ValInt len | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fourfuns{string-escaped}{ocaml-escaped}{html-escaped}{html-pre-escaped} * \fourfuns{c-escaped}{id-escaped}{sql-escaped}{uri-escaped} * * \begin{verbatim} * $(string-escaped sequence) : String Array * $(ocaml-escaped sequence) : String Array * $(html-escaped sequence) : String Array * $(html-pre-escaped sequence) : String Array * $(c-escaped sequence) : String Array * $(id-escaped sequence) : StringArray * $(sql-escaped sequence) : StringArray * $(uri-escaped sequence) : StringArray * sequence : Array * \end{verbatim} * * The \verb+string-escaped+ function converts each element of its * argument to a string, escaping it, if it contains symbols that are * special to \OMake. * The special characters include \verb+:()\,$'"#+ and whitespace. * This function can be used in scanner rules to escape file names before * printing then to \verb+stdout+. * * The \verb+ocaml-escaped+ function converts each element of its * argument to a string, escaping characters that are special to OCaml. * * The \verb+c-escaped+ function converts a string to a form that * can be used as a string constant in C. * * The \verb+id-escaped+ function turns a string into an identifier that * may be used in \OMake. * * The \verb+html-escaped+ function turns a literal string into a form acceptable * as HTML. The \verb+html-pre-escaped+ function is similar, but it does not * translate newlines into \verb+
+. * * \begin{verbatim} * println($(string $(string-escaped $"a b" $"y:z"))) * a\ b y\:z * \end{verbatim} * \end{doc} *" *) (* * Generic escaping functions *) let escape_length test extra s = let len = String.length s in let rec collect amount i = if i = len then amount else if test s.[i] then collect (amount + extra) (i + 1) else collect (amount + 1) (i + 1) in collect 0 0 let copy_string test add_escape esc_length src_length s = let esc_string = Bytes.create esc_length in let rec copy esc_index src_index = if src_index <> src_length then let c = s.[src_index] in if test c then begin let extra_length = add_escape esc_string esc_index c in copy (esc_index + extra_length) (src_index + 1) end else begin Bytes.set esc_string esc_index c; copy (esc_index + 1) (src_index + 1) end in copy 0 0; Bytes.to_string esc_string (* * Escape special symbols. * NB: Must be compatible with the Omake_ast_lex.parse_deps function! *) let is_escape_char c = match c with ' ' | '\t' | '\n' | ':' | ')' | '(' | ',' | '$' | '\'' | '\"' | '\\' | '#' -> true | _ -> false let add_single_escape (s : bytes) i c = Bytes.set s i '\\'; Bytes.set s (i + 1) c; 2 let single_escaped s = let src_length = String.length s in let esc_length = escape_length is_escape_char 2 s in if esc_length = src_length then s else copy_string is_escape_char add_single_escape esc_length src_length s (* * Escape in a way that produces a valid identifier. *) let id_is_escape c = match c with 'A'..'Z' | 'a'..'z' | '0'..'9' -> false | _ -> true let id_char c = if c < 10 then Char.chr (c + Char.code '0') else Char.chr (c + Char.code 'a') let id_add_quote s i c = Bytes.set s i '_'; Bytes.set s (i + 1) (id_char ((Char.code c) lsr 4)); Bytes.set s (i + 2) (id_char ((Char.code c) land 0x0f)); 3 let id_single_escaped s = let src_length = String.length s in let esc_length = escape_length id_is_escape 3 s in if esc_length = src_length then s else copy_string id_is_escape id_add_quote esc_length src_length s let any_escaped escaped venv pos loc args : Omake_value_type.t = let pos = string_pos "string-escaped" pos in match args with [arg] -> let args = Omake_eval.strings_of_value venv pos arg in let args = List.map (fun s -> try Omake_value_type.ValData (escaped s) with Failure _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("illegal string argument", s)))) args in ValArray args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let string_escaped = any_escaped single_escaped let ocaml_escaped = any_escaped String.escaped let c_escaped = any_escaped Lm_string_util.c_escaped let sql_escaped = any_escaped Lm_string_util.sql_escaped let id_escaped = any_escaped id_single_escaped let html_escaped = any_escaped Lm_string_util.html_escaped let html_pre_escaped = any_escaped Lm_string_util.html_pre_escaped (* * \begin{doc} * \twofuns{hexify}{unhexify} * * \begin{verbatim} * $(hexify sequence) : sequence * sequence : Sequence * \end{verbatim} * * The function \verb+hexify+ converts a string to a HEX ASCII representation. * The inverse function is \verb+unhexify+. * * \begin{verbatim} * osh> hexify($"Hello world") * - : > * \end{verbatim} * \end{doc} *) let hexify = any_escaped Lm_string_util.hexify let unhexify = any_escaped Lm_string_util.unhexify (* * \begin{doc} * \twofuns{decode-uri}{encode-uri} * * \begin{verbatim} * $(decode-uri sequence) : sequence * sequence : Sequence * \end{verbatim} * * These two functions perform URI encoding, where special characters * are represented by hexadecimal characters. * * \begin{verbatim} * osh> s = $(encode-uri $'a b~c') * "a+b%7ec" * osh> decode-uri($s) * "a b~c" * \end{verbatim} * \end{doc} *) let decode_uri = any_escaped Lm_string_util.decode_hex_name let encode_uri = any_escaped Lm_string_util.encode_hex_name (* * \begin{doc} * \fun{quote} * * \begin{verbatim} * $(quote sequence) : String * sequence : Sequence * \end{verbatim} * * The \verb+quote+ function flattens a sequence into a single string * and adds quotes around the string. Inner quotation symbols are * escaped. * * For example, the expression \verb+$(quote a "b c" d)+ evaluates * to \verb+"a \"b c\" d"+, and \verb+$(quote abc)+ evaluates to * \verb+"abc"+. * \end{doc} *) let quote venv pos loc args : Omake_value_type.t = let pos = string_pos "quote" pos in match args with | [arg] -> let argv = Omake_eval.strings_of_value venv pos arg in let s = Lm_string_util.quote_argv argv in ValData s | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{quote-argv} * * \begin{verbatim} * $(quote-argv sequence) : String * sequence : Sequence * \end{verbatim} * * The \verb+quote-argv+ function flattens a sequence into a single string, * and adds quotes around the string. The quotation is formed so that * a command-line parse can separate the string back into its components. * \end{doc} *) let quote_argv venv pos loc args : Omake_value_type.t = let pos = string_pos "quote-argv" pos in match args with [arg] -> let argv = Omake_eval.strings_of_value venv pos arg in let s = Lm_string_util.concat_argv argv in ValData s | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{html-string} * * \begin{verbatim} * $(html-string sequence) : String * sequence : Sequence * \end{verbatim} * * The \verb+html-string+ function flattens a sequence into a single string, * and escapes special HTML characters. * This is similar to the \verb+concat+ function, but the elements are * separated by whitespace. The result is treated as a unit; whitespace * inside sequence elements is preserved literally. * \end{doc} *) let html_string venv pos loc args : Omake_value_type.t = let pos = string_pos "html-string" pos in match args with [arg] -> let args = Omake_eval.strings_of_value venv pos arg in let s = String.concat " " args in let s = Lm_string_util.html_escaped_nonwhite s in ValData s | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Add a suffix. * * \begin{doc} * \fun{addsuffix} * * \begin{verbatim} * $(addsuffix suffix, sequence) : Array * suffix : String * sequence : Sequence * \end{verbatim} * * The \verb+addsuffix+ function adds a suffix to each component of sequence. * The number of elements in the array is exactly the same as the number of * elements in the sequence. * * For example, \verb+$(addsuffix .c, a b "c d")+ evaluates to \verb+a.c b.c "c d".c+. * \end{doc} *) let addsuffix venv pos loc args : Omake_value_type.t = let pos = string_pos "addsuffix" pos in match args with | [suffix; arg] -> let args = Omake_eval.values_of_value venv pos arg in let args = List.map (fun v -> Omake_value_type.ValSequence [v; suffix]) args in ValArray args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Add a suffix. * * \begin{doc} * \fun{mapsuffix} * * \begin{verbatim} * $(mapsuffix suffix, sequence) : Array * suffix : value * sequence : Sequence * \end{verbatim} * * The \verb+mapsuffix+ function adds a suffix to each component of sequence. * It is similar to \verb+addsuffix+, but uses array concatenation instead * of string concatenation. The number of elements in the array is * twice the number of elements in the sequence. * * For example, \verb+$(mapsuffix .c, a b "c d")+ evaluates to \verb+a .c b .c "c d" .c+. * \end{doc} *) let mapsuffix venv pos loc args : Omake_value_type.t = let pos = string_pos "mapsuffixe" pos in match args with | [suffix; arg] -> let args = Omake_eval.values_of_value venv pos arg in let args = List.map (fun v -> Omake_value_type.ValArray [v; suffix]) args in ValArray args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Add all suffixes. * * \begin{doc} * \twofuns{addsuffixes}{addprefixes} * * \begin{verbatim} * $(addsuffixes suffixes, sequence) : Array * suffixes : Sequence * sequence : Sequence * $(addprefixes prefixes, sequence) : Array * prefixes : Sequence * sequence : Sequence * \end{verbatim} * * The \verb+addsuffixes+ function adds all suffixes in its first argument * to each component of a sequence. If \verb+suffixes+ has \verb+n+ elements, * and \verb+sequence+ has \verb+m+ elements, the the result has \verb+n * m+ elements. * * For example, the \verb+$(addsuffixes .c .o, a b c)+ expressions evaluates to * \verb+a.c a.o b.c b.o c.o c.a+. * * \verb+$(addprefixes prefixes, sequence)+ is roughly equivalent to \verb+$(addsuffixes sequence, prefixes)+. * \end{doc} *) let addsuffixes venv pos loc args : Omake_value_type.t = let pos = string_pos "addsuffixes" pos in match args with | [suffix; arg] -> let suffixes = Omake_eval.strings_of_value venv pos suffix in let suffixes = List.map (fun s -> Omake_value_type.ValString s) suffixes in let args = Omake_eval.values_of_value venv pos arg in let args = List.map (fun suffix -> List.map (fun s -> Omake_value_type.ValSequence [s; suffix]) args) suffixes in ValArray (List.flatten args) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) let addprefixes venv pos loc args : Omake_value_type.t = let pos = string_pos "addprefixes" pos in match args with | [prefixes; arg] -> let prefixes = Omake_eval.strings_of_value venv pos prefixes in let prefixes = List.map (fun s -> Omake_value_type.ValString s) prefixes in let args = Omake_eval.values_of_value venv pos arg in let args = List.map (fun prefix -> List.map (fun s -> Omake_value_type.ValSequence [prefix; s]) args) prefixes in ValArray (List.flatten args) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * \begin{doc} * \fun{removeprefix} * * \begin{verbatim} * $(removeprefix prefix, sequence) : Array * prefix : String * sequence : Array * \end{verbatim} * * The \verb+removeprefix+ function removes a prefix from each component * of a sequence. * \end{doc} *) let removeprefix venv pos loc args = let pos = string_pos "removeprefix" pos in match args with [pre; arg] -> let pre = Omake_eval.string_of_value venv pos pre in let args = Omake_eval.strings_of_value venv pos arg in let plen = String.length pre in let args = List.map (fun s -> if Lm_string_util.equal_substring s 0 pre then String.sub s plen (String.length s - plen) else s) args in Omake_value.concat_strings args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Remove suffixes. * * \begin{doc} * \fun{removesuffix} * * \begin{verbatim} * $(removesuffix sequence) : Array * sequence : String * \end{verbatim} * * The \verb+removesuffix+ function removes the suffixes from each component * of a sequence. * * For example, \verb+$(removesuffix a.c b.foo "c d")+ expands to \verb+a b "c d"+. * \end{doc} *) let removesuffix venv pos loc args = let pos = string_pos "removesuffix" pos in match args with [arg] -> let args = Omake_eval.strings_of_value venv pos arg in let args = List.map Lm_filename_util.root args in Omake_value.concat_strings args | [suffix; arg] -> let suffix = Omake_eval.string_of_value venv pos suffix in let args = Omake_eval.strings_of_value venv pos arg in let slen = String.length suffix in let args = List.map (fun s -> let len = String.length s in let off = len - slen in if Lm_string_util.equal_substring s off suffix then String.sub s 0 off else s) args in Omake_value.concat_strings args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (1, 2), List.length args))) (* * Replace suffixes. * * \begin{doc} * \fun{replacesuffixes} * * \begin{verbatim} * $(replacesuffixes old-suffixes, new-suffixes, sequence) : Array * old-suffixes : Sequence * new-suffixes : Sequence * sequence : Sequence * \end{verbatim} * * The \verb+replacesuffixes+ function modifies the suffix of each component * in sequence. The \verb+old-suffixes+ and \verb+new-suffixes+ sequences * should have the same length. * * For example, \verb+$(replacesuffixes .h .c, .o .o, a.c b.h c.z)+ expands to \verb+a.o b.o c.z+. * \end{doc} *) let replacesuffixes venv pos loc args = let pos = string_pos "replacesuffixes" pos in match args with [old_suffixes; new_suffixes; files] -> let old_suffixes = Omake_eval.strings_of_value venv pos old_suffixes in let new_suffixes = Omake_eval.strings_of_value venv pos new_suffixes in let files = Omake_eval.strings_of_value venv pos files in let len1 = List.length old_suffixes in let len2 = List.length new_suffixes in let _ = if len1 <> len2 then raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact len1, len2))) in let table = List.fold_left2 Lm_string_set.StringTable.add Lm_string_set.StringTable.empty old_suffixes new_suffixes in let files = List.map (fun file -> let root, old_suffix = Lm_filename_util.split file in try let new_suffix = Lm_string_set.StringTable.find table old_suffix in root ^ new_suffix with Not_found -> file) files in Omake_value.concat_strings files | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 3, List.length args))) (* * Add a prefix. * * \begin{doc} * \fun{addprefix} * * \begin{verbatim} * $(addprefix prefix, sequence) : Array * prefix : String * sequence : Sequence * \end{verbatim} * * The \verb+addprefix+ function adds a prefix to each component of a sequence. * The number of element in the result array is exactly the same as the number * of elements in the argument sequence. * * For example, \verb+$(addprefix foo/, a b "c d")+ evaluates to \verb+foo/a foo/b foo/"c d"+. * \end{doc} *) let addprefix venv pos loc args : Omake_value_type.t = let pos = string_pos "addprefix" pos in match args with |[prefix; arg] -> let args = Omake_eval.values_of_value venv pos arg in let args = List.map (fun v -> Omake_value_type.ValSequence [prefix; v]) args in ValArray args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Add a prefix. * * \begin{doc} * \fun{mapprefix} * * \begin{verbatim} * $(mapprefix prefix, sequence) : Array * prefix : String * sequence : Sequence * \end{verbatim} * * The \verb+mapprefix+ function adds a prefix to each component of a sequence. * It is similar to \verb+addprefix+, but array concatenation is used instead of * string concatenation. The result array contains twice as many elements * as the argument sequence. * * For example, \verb+$(mapprefix foo, a b "c d")+ expands to \verb+foo a foo b foo "c d"+. * \end{doc} *) let mapprefix venv pos loc args : Omake_value_type.t = let pos = string_pos "mapprefix" pos in match args with | [prefix; arg] -> let args = Omake_eval.values_of_value venv pos arg in let args = List.map (fun v -> Omake_value_type.ValArray [prefix; v]) args in ValArray args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Add both prefix and suffix. * * \begin{doc} * \fun{add-wrapper} * * \begin{verbatim} * $(add-wrapper prefix, suffix, sequence) : Array * prefix : String * suffix : String * sequence : Sequence * \end{verbatim} * * The \verb+add-wrapper+ functions adds both a prefix and a suffix to each component of a sequence. * For example, the expression \verb+$(add-wrapper dir/, .c, a b)+ evaluates to * \verb+dir/a.c dir/b.c+. String concatenation is used. The array result * has the same number of elements as the argument sequence. * \end{doc} *) let add_wrapper venv pos loc args : Omake_value_type.t = let pos = string_pos "add-wrapper" pos in match args with | [prefix; suffix; arg] -> let args = Omake_eval.values_of_value venv pos arg in let args = List.map (fun s -> Omake_value_type.ValSequence [prefix; s; suffix]) args in ValArray args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 3, List.length args))) (* * Eliminate duplicates. * * \begin{doc} * \fun{set} * * \begin{verbatim} * $(set sequence) : Array * sequence : Sequence * \end{verbatim} * * The \verb+set+ function sorts a set of string components, eliminating duplicates. * * For example, \verb+$(set z y z "m n" w a)+ expands to \verb+"m n" a w y z+. * \end{doc} *) let set venv pos loc args : Omake_value_type.t = let pos = string_pos "set" pos in match args with | [files] -> let files = Omake_eval.strings_of_value venv pos files in let files = List.fold_left Lm_string_set.LexStringSet.add Lm_string_set.LexStringSet.empty files in let files = Lm_string_set.LexStringSet.fold (fun strings s -> Omake_value_type.ValString s :: strings) [] files in ValArray (List.rev files) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Set membership. * * \begin{doc} * \fun{mem} * * \begin{verbatim} * $(mem elem, sequence) : Boolean * elem : String * sequence : Sequence * \end{verbatim} * * The \verb+mem+ function tests for membership in a sequence. * * For example, \verb+$(mem "m n", y z "m n" w a)+ evaluates to \verb+true+, * while \verb+$(mem m n, y z "m n" w a)+ evaluates to \verb+false+. * \end{doc} *) let mem venv pos loc args : Omake_value_type.t = let pos = string_pos "mem" pos in match args with | [s; set] -> let s = Lm_string_util.trim (Omake_eval.string_of_value venv pos s) in let set = Omake_eval.strings_of_value venv pos set in Omake_builtin_util.val_of_bool (List.mem s set) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Set intersection. * * \begin{doc} * \fun{intersection} * * \begin{verbatim} * $(intersection sequence1, sequence2) : Array * sequence1 : Sequence * sequence2 : Sequence * \end{verbatim} * * The \verb+intersection+ function takes two arguments, treats them * as sets of strings, and computes their intersection. The order of the result * is undefined, and it may contain duplicates. Use the \verb+set+ * function to sort the result and eliminate duplicates in the result * if desired. * * For example, the expression \verb+$(intersection c a b a, b a)+ evaluates to * \verb+a b a+. * \end{doc} *) let intersection venv pos loc args : Omake_value_type.t = let pos = string_pos "intersection" pos in let rec intersect l = function | h :: t -> if List.mem h l then h :: intersect l t else intersect l t | [] -> [] in match args with | [files1; files2] -> let files1 = Omake_eval.strings_of_value venv pos files1 in let files2 = Omake_eval.strings_of_value venv pos files2 in let files = intersect files1 files2 in ValArray (List.map (fun s -> Omake_value_type.ValString s) files) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * \begin{doc} * \fun{intersects} * * \begin{verbatim} * $(intersects sequence1, sequence2) : Boolean * sequence1 : Sequence * sequence2 : Sequence * \end{verbatim} * * The \verb+intersects+ function tests whether two sets have a non-empty intersection. * This is slightly more efficient than computing the intersection and testing whether * it is empty. * * For example, the expression \verb+$(intersects a b c, d c e)+ evaluates to \verb+true+, * and \verb+$(intersects a b c a, d e f)+ evaluates to \verb+false+. * \end{doc} *) let intersects venv pos loc args = let pos = string_pos "intersects" pos in let rec intersects l = function h::t -> List.mem h l || intersects l t | [] -> false in match args with [files1; files2] -> let files1 = Omake_eval.strings_of_value venv pos files1 in let files2 = Omake_eval.strings_of_value venv pos files2 in Omake_builtin_util.val_of_bool (intersects files1 files2) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Set subtraction. * * \begin{doc} * \fun{set-diff} * * \begin{verbatim} * $(set-diff sequence1, sequence2) : Array * sequence1 : Sequence * sequence2 : Sequence * \end{verbatim} * * The \verb+set-diff+ function takes two arguments, treats them * as sets of strings, and computes their difference (all the elements of the * first set that are not present in the second one). The order of the result * is undefined and it may contain duplicates. Use the \verb+set+ * function to sort the result and eliminate duplicates in the result * if desired. * * For example, the expression \verb+$(set-diff c a b a e, b a)+ evaluates to * \verb+c e+. * \end{doc} *) let set_diff venv pos loc args : Omake_value_type.t = let pos = string_pos "set_diff" pos in let rec diff l = function | h :: t -> if List.mem h l then diff l t else h :: diff l t | [] -> [] in match args with [files1; files2] -> let files1 = Omake_eval.strings_of_value venv pos files1 in let files2 = Omake_eval.strings_of_value venv pos files2 in let files = diff files2 files1 in ValArray (List.map (fun s -> Omake_value_type.ValString s) files) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Include all files that do not match the pattern. * * \begin{doc} * \fun{filter} * * \begin{verbatim} * $(filter patterns, sequence) : Array * patterns : Sequence * sequence : Sequence * \end{verbatim} * * The \verb+filter+ function picks elements from a sequence. * The patterns is a non-empty sequence of patterns, each may contain one occurrence of the wildcard * \verb+%+ character. * * For example \verb+$(filter %.h %.o, a.c x.o b.h y.o "hello world".c)+ evaluates to \verb+x.o b.h y.o+. * \end{doc} *) let compile_patterns venv _ pos patterns = let patterns = Omake_eval.strings_of_value venv pos patterns in let rec f = function [] -> (fun _ -> false) | pattern :: patterns -> let f = f patterns in if Lm_wild.is_wild pattern then let wild = Lm_wild.compile_in pattern in (fun s -> Lm_wild.wild_match wild s <> None || f s) else (fun s -> s = pattern || f s) in f patterns let filter venv pos loc args : Omake_value_type.t = let pos = string_pos "filter" pos in match args with | [patterns; arg] -> let args = Omake_eval.strings_of_value venv pos arg in let args = List.filter (compile_patterns venv loc pos patterns) args in ValArray (List.map (fun s -> Omake_value_type.ValString s) args) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Include all files that do not match the pattern. * * \begin{doc} * \fun{filter-out} * * \begin{verbatim} * $(filter-out patterns, sequence) : Array * patterns : Sequence * sequence : Sequence * \end{verbatim} * * The \verb+filter-out+ function removes elements from a sequence. * The patterns is a non-empty sequence of patterns, each may contain one occurrence of the wildcard * \verb+%+ character. * * For example \verb+$(filter-out %.c %.h, a.c x.o b.h y.o "hello world".c)+ evaluates to \verb+x.o y.o+. * \end{doc} *) let filter_out venv pos loc args : Omake_value_type.t = let pos = string_pos "filter-out" pos in match args with | [patterns; arg] -> let args = Omake_eval.strings_of_value venv pos arg in let f = compile_patterns venv loc pos patterns in let args = List.filter (fun s -> not (f s)) args in ValArray (List.map (fun s -> Omake_value_type.ValString s) args) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Capitalize some words. * * \begin{doc} * \fun{capitalize} * * \begin{verbatim} * $(capitalize sequence) : Array * sequence : Sequence * \end{verbatim} * * The \verb+capitalize+ function capitalizes each word in a sequence. * For example, \verb+$(capitalize through the looking Glass)+ evaluates to * \verb+Through The Looking Glass+. * \end{doc} *) let capitalize venv pos loc args = let pos = string_pos "capitalize" pos in match args with [arg] -> let args = Omake_eval.strings_of_value venv pos arg in let args = List.map String.capitalize_ascii args in Omake_value.concat_strings args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Uncapitalize some words. * * \begin{doc} * \fun{uncapitalize} * * \begin{verbatim} * $(uncapitalize sequence) : Array * sequence : Sequence * \end{verbatim} * * The \verb+uncapitalize+ function uncapitalizes each word in its argument. * * For example, \verb+$(uncapitalize through the looking Glass)+ evaluates to * \verb+through the looking glass+. * \end{doc} *) let uncapitalize venv pos loc args = let pos = string_pos "uncapitalize" pos in match args with [arg] -> let args = Omake_eval.strings_of_value venv pos arg in let args = List.map String.uncapitalize_ascii args in Omake_value.concat_strings args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Capitalize some words. * * \begin{doc} * \fun{uppercase} * * \begin{verbatim} * $(uppercase sequence) : Array * sequence : Sequence * \end{verbatim} * * The \verb+uppercase+ function converts each word in a sequence to uppercase. * For example, \verb+$(uppercase through the looking Glass)+ evaluates to * \verb+THROUGH THE LOOKING GLASS+. * \end{doc} *) let uppercase venv pos loc args = let pos = string_pos "uppercase" pos in match args with [arg] -> let args = Omake_eval.strings_of_value venv pos arg in let args = List.map String.uppercase_ascii args in Omake_value.concat_strings args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Uncapitalize some words. * * \begin{doc} * \fun{lowercase} * * \begin{verbatim} * $(lowercase sequence) : Array * sequence : Sequence * \end{verbatim} * * The \verb+lowercase+ function reduces each word in its argument to lowercase. * * For example, \verb+$(lowercase through tHe looking Glass)+ evaluates to * \verb+through the looking glass+. * \end{doc} *) let lowercase venv pos loc args = let pos = string_pos "lowercase" pos in match args with [arg] -> let args = Omake_eval.strings_of_value venv pos arg in let args = List.map String.lowercase_ascii args in Omake_value.concat_strings args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \fun{system} * * \begin{verbatim} * system(s) * s : Sequence * \end{verbatim} * * The \verb+system+ function is used to evaluate a shell expression. * This function is used internally by \Prog{omake} to evaluate * shell commands. * * For example, the following program is equivalent to the * expression \verb+system(ls foo)+. * * \begin{verbatim} * ls foo * \end{verbatim} * \end{doc} *) let system venv pos loc args kargs = let pos = string_pos "system" pos in match args, kargs with [arg], [] -> Omake_rule.eval_shell_exp venv pos loc arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Shell command. * * \begin{doc} * \fun{shell} * * \begin{verbatim} * $(shell command) : Array * $(shella command) : Array * $(shell-code command) : Int * command : Sequence * \end{verbatim} * * The \verb+shell+ function evaluates a command using the command shell, * and returns the whitespace-separated words of the standard output as the result. * * The \verb+shella+ function acts similarly, but it returns the lines * as separate items in the array. * * The \verb+shell-code+ function returns the exit code. The output is not * diverted. * * For example, if the current directory contains the files \verb+OMakeroot+, * \verb+OMakefile+, and \verb+hello.c+, then \verb+$(shell ls)+ evaluates to * \verb+hello.c OMakefile OMakeroot+ (on a Unix system). * \end{doc} *) let shell_aux venv pos loc args = let pos = string_pos "shell" pos in match args with [arg] -> Omake_rule.eval_shell_output venv pos loc arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let shell venv pos loc args = let s = shell_aux venv pos loc args in let args = Omake_eval.values_of_value venv pos (ValString s) in Omake_value.concat_array args let shella venv pos loc args : Omake_value_type.t = let s = shell_aux venv pos loc args in let len = String.length s in let buf = Buffer.create 32 in let flush lines = let s = Buffer.contents buf in Buffer.clear buf; if s = "" then lines else Omake_value_type.ValString s :: lines in let rec collect lines i = if i = len then flush lines else match s.[i] with '\r' | '\n' -> collect (flush lines) (succ i) | c -> Buffer.add_char buf c; collect lines (succ i) in ValArray (List.rev (collect [] 0)) let shell_code venv pos loc args = let pos = string_pos "shell-code" pos in let venv = Omake_env.venv_add_var venv Omake_var.abort_on_command_error_var Omake_builtin_util.val_false in let _, result = match args with [arg] -> Omake_rule.eval_shell_exp venv pos loc arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in match result with ValInt _ -> result | ValOther (ValExitCode i) -> ValInt i | _ -> ValInt 0 (* * Exports. * \begin{doc} * \fun{export} * The \verb+export+ function allows one to capture the current environment in a variable. * * For example, the following code: * \begin{verbatim} * A = 1 * B = 1 * C = 1 * SAVE_ENV = $(export A B) * A = 2 * B = 2 * C = 2 * export($(SAVE_ENV)) * println($A $B $C) * \end{verbatim} * will print \verb+1 1 2+. * * The arguments to this function are interpreted the exact same way as the arguments to the \verb+export+ * special form (see Section~\ref{section:export}). * \end{doc} *) let export venv pos loc (args : Omake_value_type.t list) kargs = let pos = string_pos "export" pos in match args, kargs with |[ValOther (ValEnv (hand, export))], [] -> let venv_new = Omake_env.venv_find_environment venv pos hand in let venv = Omake_env.add_exports venv venv_new pos export in venv, Omake_value_type.ValNone | [vars], [] -> let exports : Omake_ir.export_item list = List.map (function ".PHONY" -> Omake_ir.ExportPhonies | ".RULE" -> ExportRules | v -> ExportVar (VarGlobal (loc, Lm_symbol.add v))) (Omake_eval.strings_of_value venv pos vars) in let hand = Omake_env.venv_add_environment venv in venv, ValOther (ValEnv (hand, ExportList exports)) | [], [] -> let hand = Omake_env.venv_add_environment venv in venv, ValOther (ValEnv (hand, ExportAll)) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (0, 1), List.length args))) (* * Loop. * \begin{doc} * \hypertarget{while}{} * \fun{while} * * \begin{verbatim} * while * * \end{verbatim} * * --or-- * * \begin{verbatim} * while * case * * ... * case * * default * * \end{verbatim} * * The loop is executed while the test is true. * In the first form, the \verb++ is executed on every loop iteration. * In the second form, the body \verb++ is selected, as the first * case where the test \verb++ is true. If none apply, the optional * default case is evaluated. If no cases are true, the loop exits. * The environment is automatically exported. * * Examples. * * Iterate for \verb+i+ from \verb+0+ to \verb+9+. * * \begin{verbatim} * i = 0 * while $(lt $i, 10) * echo $i * i = $(add $i, 1) * \end{verbatim} * * The following example is equivalent. * * \begin{verbatim} * i = 0 * while true * case $(lt $i, 10) * echo $i * i = $(add $i, 1) * \end{verbatim} * * The following example is similar, but some special cases are printed. * value is printed. * * \begin{verbatim} * i = 0 * while $(lt $i, 10) * case $(equal $i, 0) * echo zero * i = $(add $i, 1) * case $(equal $i, 1) * echo one * i = $(add $i, 1) * default * echo $i * i = $(add $i, 1) * \end{verbatim} * * The \hyperfun{break} can be used to break out of the \verb+while+ loop * early. * \end{doc} *) let rec eval_while_cases venv pos loc orig_cases arg cases = match cases with (v, pattern, e, _) :: cases -> if Lm_symbol.eq v Omake_symbol.case_sym && Omake_eval.bool_of_value venv pos pattern || Lm_symbol.eq v Omake_symbol.default_sym then let venv, _ = Omake_eval.eval_sequence_exp venv pos e in while_loop venv pos loc orig_cases arg else eval_while_cases venv pos loc orig_cases arg cases | [] -> venv and while_loop venv pos loc cases arg = if Omake_eval.bool_of_value venv pos arg then eval_while_cases venv pos loc cases arg cases else venv let while_fun venv pos loc args kargs = let pos = string_pos "while" pos in let cases, arg = match args, kargs with [cases; arg], [] -> (match Omake_eval.eval_value venv pos cases with ValCases cases -> cases, arg | _ -> raise (Omake_value_type.OmakeException (pos, StringError "malformed while expression"))) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) in let venv = try while_loop venv pos loc cases arg with Omake_env.Break (_, venv) -> venv in venv, Omake_value_type.ValNone (* * \begin{doc} * \hypertarget{break}{} * \fun{break} * * \begin{verbatim} * break * \end{verbatim} * * Terminate execution of the innermost loop, returning the current state. * \end{doc} *) let break venv _ loc _ = raise (Omake_env.Break (loc, venv)) (* * \begin{doc} * \twofuns{random}{random-init} * * \begin{verbatim} * random-init(i) * i : Int * random() : Int * \end{verbatim} * * Produce a random number. The numbers are pseudo-random, * and are not cryptographically secure. * * The generator is initialized from semi-random system data. * Subsequent runs should produce different results. * The \verb+rando-init+ function can be used to return * the generator to a known state. * \end{doc} *) let () = Random.self_init () let random _ _ _ _ = Omake_value_type.ValInt (Random.bits ()) let random_init venv pos loc args = let pos = string_pos "random-init" pos in match args with [arg] -> let i = Omake_value.int_of_value venv pos arg in Random.init i; Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (************************************************************************ * Register. *) let () = let builtin_vars = let user = try Unix.getlogin () with Unix.Unix_error _ | Not_found -> "nobody" in ["OS", (fun _ -> Omake_value_type.ValData Sys.os_type); "OSTYPE", (fun _ -> ValData Sys.os_type); "CCOMPTYPE", (fun _ -> ValData Omake_magic.omake_ccomptype); "OMAKE_CC", (fun _ -> ValData Omake_magic.omake_cc); "OMAKE_CFLAGS", (fun _ -> ValData Omake_magic.omake_cflags); "SYSNAME", (fun _ -> ValData Lm_uname.sysname); "NODENAME", (fun _ -> ValData Lm_uname.nodename); "OS_VERSION", (fun _ -> ValData Lm_uname.version); "OS_RELEASE", (fun _ -> ValData Lm_uname.release); "MACHINE", (fun _ -> ValData Lm_uname.machine); "HOST", (fun _ -> ValData Lm_uname.nodename); "OMAKE_VERSION", (fun _ -> ValData Omake_magic.version); "USER", (fun _ -> ValData user); "PID", (fun _ -> ValInt (Unix.getpid ())); "HOME", (fun venv -> ValDir (Omake_env.venv_intern_dir venv Omake_state.home_dir)); "VERBOSE", (fun venv -> Omake_builtin_util.val_of_bool (Omake_options.opt_verbose (Omake_env.venv_options venv))); (* ZZZ: Used to be defined in Common.om *) "SCANNER_MODE", (fun _ -> ValData "enabled"); "ABORT_ON_COMMAND_ERROR", (fun _ -> Omake_builtin_util.val_true); (* ZZZ: needs documentation *) "ALLOW_EMPTY_SUBDIRS", (fun _ -> Omake_builtin_util.val_false); "CREATE_SUBDIRS", (fun _ -> Omake_builtin_util.val_false); "EXIT_ON_UNCAUGHT_EXCEPTION", (fun _ -> Omake_builtin_util.val_false); "AUTO_REHASH", (fun _ -> Omake_builtin_util.val_false); ] in (* GS: the first col says whether the primitive gets eagerly evaluated arguments. If false, you need to run Omake_eval.eval_value to force the evaluation of the lazy arguments. It is not possible to specify this per arg - either all args are eager or all args are lazy. *) let builtin_funs = [true, "addprefix", addprefix, Omake_ir.ArityExact 2; true, "mapprefix", mapprefix, ArityExact 2; true, "addprefixes", addprefixes, ArityExact 2; true, "removeprefix", removeprefix, ArityExact 2; true, "addsuffix", addsuffix, ArityExact 2; true, "mapsuffix", mapsuffix, ArityExact 2; true, "addsuffixes", addsuffixes, ArityExact 2; true, "removesuffix", removesuffix, ArityRange (1, 2); true, "replacesuffixes", replacesuffixes, ArityExact 3; (* String operations *) true, "string", string, ArityExact 1; true, "string-escaped", string_escaped, ArityExact 1; true, "string-length", string_length, ArityExact 1; true, "ocaml-escaped", ocaml_escaped, ArityExact 1; true, "c-escaped", c_escaped, ArityExact 1; true, "sql-escaped", sql_escaped, ArityExact 1; true, "id-escaped", id_escaped, ArityExact 1; true, "html-escaped", html_escaped, ArityExact 1; true, "html-pre-escaped", html_pre_escaped, ArityExact 1; true, "hexify", hexify, ArityExact 1; true, "unhexify", unhexify, ArityExact 1; true, "decode-uri", decode_uri, ArityExact 1; true, "encode-uri", encode_uri, ArityExact 1; true, "uri-escaped", encode_uri, ArityExact 1; true, "quote", quote, ArityExact 1; true, "quote-argv", quote_argv, ArityExact 1; true, "html-string", html_string, ArityExact 1; true, "add-wrapper", add_wrapper, ArityExact 3; true, "capitalize", capitalize, ArityExact 1; true, "uncapitalize", uncapitalize, ArityExact 1; true, "lowercase", lowercase, ArityExact 1; true, "uppercase", uppercase, ArityExact 1; (* System operations *) true, "getenv", getenv, ArityRange (1, 2); true, "defined-env", defined_env, ArityExact 1; true, "exit", exit_fun, ArityRange (0, 1); true, "exit-parent", exit_parent_fun, ArityRange (0, 1); true, "raise", raise_fun, ArityExact 1; true, "get-registry", get_registry, ArityRange (3, 4); (* Normal variables *) true, "getvar", getvar, ArityExact 1; (* Logic *) true, "not", not_fun, ArityExact 1; false, "or", or_fun, ArityAny; false, "and", and_fun, ArityAny; true, "equal", equal, ArityExact 2; false, "if", if_fun, ArityRange (2, 3); true, "defined", defined, ArityExact 1; (* List operations *) true, "array", array_fun, ArityAny; true, "split", split_fun, ArityRange (1, 2); true, "concat", concat_fun, ArityExact 2; true, "filter", filter, ArityExact 2; true, "filter-out", filter_out, ArityExact 2; true, "nth", nth_fun, ArityExact 2; true, "nth-hd", nth_hd_fun, ArityExact 2; true, "nth-tl", nth_tl_fun, ArityExact 2; true, "replace-nth", replace_nth_fun, ArityExact 3; true, "subrange", subrange_fun, ArityExact 3; true, "length", length_fun, ArityExact 1; true, "rev", rev_fun, ArityExact 1; (* Set operations *) true, "set", set, ArityExact 1; true, "mem", mem, ArityExact 2; true, "intersection", intersection, ArityExact 2; true, "intersects", intersects, ArityExact 2; true, "set-diff", set_diff, ArityExact 2; (* Shell command *) true, "shell", shell, ArityExact 1; true, "shella", shella, ArityExact 1; true, "shell-code", shell_code, ArityExact 1; true, "break", break, ArityExact 0; true, "random", random, ArityExact 0; true, "random-init", random_init, ArityExact 1] in let builtin_kfuns = [true, "setenv", setenv, Omake_ir.ArityExact 2; true, "unsetenv", unsetenv, ArityExact 1; true, "setvar", setvar, ArityExact 2; false, "switch", switch_fun, ArityAny; false, "match", match_fun, ArityAny; false, "while", while_fun, ArityExact 2; false, "try", try_fun, ArityExact 2; true, "export", export, ArityExact 0; true, "system", system, ArityExact 1; ] in let builtin_info = { Omake_builtin_type.builtin_empty with builtin_vars = builtin_vars; builtin_funs = builtin_funs; builtin_kfuns = builtin_kfuns } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_builtin_rule.ml0000644000175000017500000002343213177364666020002 0ustar gerdgerd(* * Some builtin functions. * * \begin{doc} * \chapter{Build functions and utilities} * \label{chapter:build} * \cutname{omake-build.html} * \end{doc} * *) include Omake_pos.Make (struct let name = "Omake_builtin_rule" end) (* * These targets are decribed in doc/src/omake-rules.tex * * \begin{doc} * \section{Builtin .PHONY targets} * * The complete set of builtin \verb+.PHONY+ targets include the following. * * \begin{description} * \item[.PHONY] Declares new phony targets (Section~\ref{target:.PHONY}). * \item[.DEFAULT] Declare the default build targets (Section~\ref{target:.DEFAULT}). * \item[.SUBDIRS] Include a directory as part of the project (Section~\ref{target:.SUBDIRS}). * \item[.SCANNER] Define a dependency scanner (Section~\ref{target:.SUBDIRS}). * \item[.INCLUDE] Include a file (Section~\ref{target:.INCLUDE}). * \item[.ORDER] Define a file-dependency ordering rule (Section~\ref{target:.ORDER}). * \item[.BUILD\_BEGIN] Commands to be executed at the beginning of a build. * \item[.BUILD\_SUCCESS] Commands to be executed if the build is successful. * \item[.BUILD\_FAILURE] Commands to be executed if the build fails. * \end{description} * * \targetlabelref{.BUILD_BEGIN}{.BUILD\_BEGIN} * \targetlabelref{.BUILD_SUCCESS}{.BUILD\_SUCCESS} * \targetlabelref{.BUILD_FAILURE}{.BUILD\_FAILURE} * * The \verb+.BUILD+ targets can be used to specify commands to be executed at * the beginning and end of the build. The \verb+.BUILD_BEGIN+ target is built * at the beginning of a project build, and one of \verb+.BUILD_FAILURE+ or * \verb+.BUILD_SUCCESS+ is executed when the build terminates. * * For example, the following set of rules simply print additional messages * about the status of the build. * * \begin{verbatim} * .BUILD_BEGIN: * echo Build starting * * .BUILD_SUCCESS: * echo The build was successful * * .BUILD_FAILURE: * println($"The build failed: $(length $(find-build-targets Failed)) targets could not be built") * \end{verbatim} * * Another common use is to define notifications to be performed when * the build completes. For example, the following rule will create * a new X terminal displaying the summary of the build * (using the \hypervarx{BUILD_SUMMARY}{BUILD\_SUMMARY}). * * \begin{verbatim} * .BUILD_FAILURE: * xterm -e vi $(BUILD_SUMMARY) * \end{verbatim} * * If you do not wish to add these rules directly to your project (which * is probably a good idea if you work with others), you can * define them in your \verb+.omakerc+ (see Section~\ref{section:.omakerc}). * * The \hyperfun{find-build-targets} * is useful for obtaining a firther summary of the build. Note that * when output diversions are in effect (with the \verb+--output-*+ options --- see Chapter~\ref{chapter:options}), * any output produced by the commands is copied to a file. The name of the * file is specified by the \verb+output-file+ field of the \hyperobj{Target}. * You may find this useful in defining custom build summaries. * \end{doc} *) let phony_targets = [".PHONY"; ".DEFAULT"; ".SUBDIRS"; ".SCANNER"; ".INCLUDE"; ".ORDER"; ".BUILD_BEGIN"; ".BUILD_SUCCESS"; ".BUILD_FAILURE"] (************************************************************************ * Set options. * * \begin{doc} * \section{Options and versioning} * \fun{OMakeFlags} * * \begin{verbatim} * OMakeFlags(options) * options : String * \end{verbatim} * * The \verb+OMakeFlags+ function is used to set \verb+omake+ options from * within \File{OMakefile}s. The options have exactly the same format as * options on the command line. * * For example, the following code displays the progress bar unless * the \verb+VERBOSE+ environment variable is defined. * * \begin{verbatim} * if $(not $(defined-env VERBOSE)) * OMakeFlags(-S --progress) * export * \end{verbatim} * \end{doc} *) let set_options venv pos loc args _ = let pos = string_pos "OMakeFlags" pos in match args with [arg] -> let argv = Omake_value.strings_of_value venv pos arg in let venv = Omake_env.venv_set_options venv loc pos argv in venv, Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Version checking. * * \begin{doc} * \fun{OMakeVersion} * * \begin{verbatim} * OMakeVersion(version1) * OMakeVersion(version1, version2) * version1, version2 : String * \end{verbatim} * * The \verb+OMakeVersion+ function is used for version checking * in \File{OMakefile}s. It takes one or two arguments. * * In the one argument form, if the \Prog{omake} version number * is less than \verb++, * then an exception is raised. In the two argument form, * the version must lie between \verb+version1+ and \verb+version2+. * * \fun{cmp-versions} * \begin{verbatim} * $(cmp-versions version1, version2) * version1, version2 : String * \end{verbatim} * * The \verb+cmp-versions\+ functions can be used to compare arbitrary version strings. * It returns 0 when the two version strings are equal, a negative number when the first * string represents an earlier version, and a positive number otherwise. * \end{doc} *) let split_int = let rec split_int_aux i s = match String.length s with 0 -> i, s | l -> begin match s.[0] with '0'..'9' as c -> split_int_aux (i * 10 + (Char.code c - 48)) (String.sub s 1 (l - 1)) | _ -> i, s end in split_int_aux 0 let rec compare_versions v1 v2 = match String.length v1, String.length v2 with 0, 0 -> 0 | 0, _ -> -1 | _, 0 -> 1 | l1, l2 -> begin match v1.[0],v2.[0] with '0'..'9', '0'..'9' -> let i1, s1 = split_int v1 in let i2, s2 = split_int v2 in begin match i1 - i2 with 0 -> compare_versions s1 s2 | i -> i end | c1, c2 when c1 = c2 -> compare_versions (String.sub v1 1 (l1 - 1)) (String.sub v2 1 (l2 - 1)) | c1, c2 -> Char.code c1 - Char.code c2 end let check_version venv pos loc args = let pos = string_pos "check_version" pos in let version = Omake_magic.version in let check lowest highest = if compare_versions version lowest < 0 then raise (Omake_value_type.OmakeFatalErr (loc_pos loc pos, LazyError (fun out -> Format.fprintf out "@[<0>This version of OMake is too old,@ you need to upgrade to at least version@ %s;@ current OMake version is@ %s.@ You should be able to download the latest version of OMake from http://omake.metaprl.org/download.html@]" lowest version))); match highest with Some highest -> if compare_versions version highest > 0 then raise (Omake_value_type.OmakeFatalErr (loc_pos loc pos, LazyError (fun out -> Format.fprintf out "@[<0>This version of OMake is too new or the given file is too old.@ This file accepts versions@ %s-%s;@ current OMake version is@ %s@]" lowest highest version))) | None -> () in match args with [lowest] -> let lowest = Lm_string_util.trim (Omake_value.string_of_value venv pos lowest) in check lowest None; Omake_value_type.ValString version | [lowest; highest] -> let lowest = Lm_string_util.trim (Omake_value.string_of_value venv pos lowest) in let highest = Lm_string_util.trim (Omake_value.string_of_value venv pos highest) in check lowest (Some highest); ValString version | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (1,2), List.length args))) let cmp_version venv pos loc args = let pos = string_pos "cmp_version" pos in match args with [v1; v2] -> let v1 = Lm_string_util.trim (Omake_value.string_of_value venv pos v1) in let v2 = Lm_string_util.trim (Omake_value.string_of_value venv pos v2) in Omake_value_type.ValInt (compare_versions v1 v2) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* * Add the command-line vars. * * \begin{doc} * \fun{DefineCommandVars} * * \begin{verbatim} * DefineCommandVars() * \end{verbatim} * * The \verb+DefineCommandVars+ function redefines the variables passed on * the commandline. Variables definitions are passed on the command line * in the form \verb+name=value+. This function is primarily for internal * use by \Prog{omake} to define these variables for the first time. * \end{doc} *) let define_command_vars venv pos loc args kargs = let pos = string_pos "DefineCommandVars" pos in match args, kargs with [], [] | [_], [] -> Omake_builtin.venv_add_command_defs venv, Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityRange (0, 1), List.length args))) (* * Table of built-in functions. *) let () = let builtin_funs = [true, "OMakeVersion", check_version, Omake_ir.ArityRange (1, 2); true, "cmp-versions", cmp_version, ArityExact 2; ] in let builtin_kfuns = [true, "OMakeFlags", set_options, Omake_ir.ArityExact 1; true, "DefineCommandVars", define_command_vars, ArityRange (0, 1); ] in let builtin_rules = [true, [".PHONY"], phony_targets] in let builtin_info = { Omake_builtin_type.builtin_empty with builtin_funs = builtin_funs; builtin_kfuns = builtin_kfuns; builtin_rules = builtin_rules; phony_targets = phony_targets } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_builtin_util.ml0000644000175000017500000000427113177364666020010 0ustar gerdgerd module Pos = Omake_pos.Make (struct let name = "Omake_builtin" end) (* * Variable manipulations. *) let defined_sym venv pos loc s = let pos = Pos.string_pos "defined_sym" pos in let v, vl = Omake_build_util.parse_sym venv pos loc s in match vl with [] -> Omake_env.venv_defined venv v | _ -> Omake_eval.eval_defined_field venv pos loc v vl let get_sym venv pos loc s = let pos = Pos.string_pos "get_sym" pos in let v, vl = Omake_build_util.parse_sym venv pos loc s in match vl with | [] -> Omake_env.venv_find_var venv pos loc v | _ -> snd (Omake_eval.eval_find_method venv pos loc v vl) let add_sym venv pos loc s x = let pos = Pos.string_pos "add_sym" pos in let v, vl = Omake_build_util.parse_sym venv pos loc s in if vl <> [] then raise (Omake_value_type.OmakeException (Pos.loc_pos loc pos, StringError "name has too many components")); Omake_env.venv_add_var venv v x (* * Fold its in a sequence, and place separators between them. *) let sequence_map f sl = let white = Omake_value_type.ValString " " in let rec collect seq sl = match sl with s :: sl -> let s = f s in let seq = if seq = [] then [s] else s :: white :: seq in collect seq sl | [] -> List.rev seq in collect [] sl (* * Add separators to a list. *) let sequence_list sl = let white = Omake_value_type.ValString " " in let rec collect sl = match sl with [s] -> [s] | s :: sl -> s :: white :: collect sl | [] -> [] in collect sl (* * Default Boolean values. *) let val_true = Omake_value_type.ValData "true" let val_false = Omake_value_type.ValData "false" let val_of_bool b = if b then val_true else val_false (* * Extend an object with another. * The argument may be a file or an object. *) let object_of_file venv pos loc s : Omake_value_type.obj = let pos = Pos.string_pos "extends" pos in let node = Omake_eval.find_include_file venv pos loc s in try Omake_env.venv_find_object_file_exn venv node with Not_found -> let obj = Omake_eval.eval_object_file venv pos loc node in Omake_env.venv_add_object_file venv node obj; obj omake-0.10.3/src/builtin/omake_builtin_test.ml0000644000175000017500000007237013177364666020017 0ustar gerdgerd(* * The Unix-style test command. * See the usage comment below. * * \begin{doc} * \section{File predicates} * \end{doc} *) include Omake_pos.Make (struct let name = "Omake_builtin_test" end) (************************************************************************ * Types. *) (* * Operators. *) type unop = IsEmptyStringOp (* -z *) | IsNonEmptyStringOp (* -n *) | IsBlockSpecialFileOp (* -b *) | IsCharSpecialFileOp (* -c *) | IsDirFileOp (* -d *) | ExistsFileOp (* -e *) | IsRegFileOp (* -f *) | IsSetgidFileOp (* -g *) | IsSymlinkFileOp (* -h, -L *) | IsGroupOwnerFileOp (* -G *) | IsStickyFileOp (* -k *) | IsOwnerFileOp (* -O *) | IsNamedPipeOp (* -p *) | IsReadableFileOp (* -r *) | IsNonemptyFileOp (* -s *) | IsSocketFileOp (* -S *) | IsSetuidFileOp (* -u *) | IsWritableFileOp (* -w *) | IsExecutableFileOp (* -x *) type binop = EqStringOp (* = *) | NeStringOp (* != *) | EqFileOp (* -ef *) | NtFileOp (* -nt *) | OtFileOp (* -ot *) type intop = EqIntOp (* -eq *) | GeIntOp (* -ge *) | GtIntOp (* -gt *) | LeIntOp (* -le *) | LtIntOp (* -lt *) | NeIntOp (* -ne *) type token = TokString of string | TokCurrentFile of string | TokNot of string | TokAnd of string | TokOr of string | TokLeftParen of string | TokRightParen of string | TokLengthOp of string | TokUnop of unop * string | TokBinop of binop * string | TokIntop of intop * string | TokName of string | TokRegex of string (* * Expressions. *) type string_exp = token type int_exp = IntExp of token | LengthExp of token type bool_exp = UnopExp of unop * string_exp | MatchExp of Lm_lexer.LmStr.t | BinopExp of binop * string_exp * string_exp | IntopExp of intop * int_exp * int_exp | NotExp of bool_exp | AndExp of bool_exp * bool_exp | OrExp of bool_exp * bool_exp (************************************************************************ * Utilities. *) let rec split_last l = match l with [x] -> [], x | h :: l -> let l, x = split_last l in h :: l, x | [] -> raise (Invalid_argument "split_last") (************************************************************************ * Token operations. *) (* * Tokenize the strings. * It is unlikely that OCaml optimizes this match, * but the performance is not all that critical. *) let token_of_string s = match s with "(" -> TokLeftParen s | ")" -> TokRightParen s | "{}" -> TokCurrentFile s | "!" -> TokNot s | "-a" -> TokAnd s | "-o" -> TokOr s | "=" -> TokBinop (EqStringOp, s) | "!=" -> TokBinop (NeStringOp, s) | "-eq" -> TokIntop (EqIntOp, s) | "-ge" -> TokIntop (GeIntOp, s) | "-gt" -> TokIntop (GtIntOp, s) | "-le" -> TokIntop (LeIntOp, s) | "-lt" -> TokIntop (LtIntOp, s) | "-ne" -> TokIntop (NeIntOp, s) | "-ef" -> TokBinop (EqFileOp, s) | "-nt" -> TokBinop (NtFileOp, s) | "-ot" -> TokBinop (OtFileOp, s) | "-n" -> TokUnop (IsNonEmptyStringOp, s) | "-z" -> TokUnop (IsEmptyStringOp, s) | "-b" -> TokUnop (IsBlockSpecialFileOp, s) | "-c" -> TokUnop (IsCharSpecialFileOp, s) | "-d" -> TokUnop (IsDirFileOp, s) | "-e" -> TokUnop (ExistsFileOp, s) | "-f" -> TokUnop (IsRegFileOp, s) | "-g" -> TokUnop (IsSetgidFileOp, s) | "-h" | "-L" -> TokUnop (IsSymlinkFileOp, s) | "-l" -> TokLengthOp s | "-G" -> TokUnop (IsGroupOwnerFileOp, s) | "-k" -> TokUnop (IsStickyFileOp, s) | "-O" -> TokUnop (IsOwnerFileOp, s) | "-p" -> TokUnop (IsNamedPipeOp, s) | "-r" -> TokUnop (IsReadableFileOp, s) | "-s" -> TokUnop (IsNonemptyFileOp, s) | "-S" -> TokUnop (IsSocketFileOp, s) | "-u" -> TokUnop (IsSetuidFileOp, s) | "-w" -> TokUnop (IsWritableFileOp, s) | "-x" -> TokUnop (IsExecutableFileOp, s) | "-name" -> TokName s | "-regex" | "-regexp" -> TokRegex s | _ -> TokString s (* * Get the string from a token. *) let string_of_token arg = match arg with TokString s | TokCurrentFile s | TokNot s | TokAnd s | TokOr s | TokLeftParen s | TokRightParen s | TokLengthOp s | TokUnop (_, s) | TokBinop (_, s) | TokIntop (_, s) | TokRegex s | TokName s -> s (* * Integer of a token. * Since we use the internal int_of_string, we can read numbers * that are not in decimal. *) let int_of_token arg = int_of_string (string_of_token arg) (* * Length of a token. *) let length_of_token arg = String.length (string_of_token arg) (************************************************************************ * Stat operations. *) (* * Translate the filename. *) let filename_of_string venv pos s = Omake_value.filename_of_value venv pos (ValString s) (* * Generic stat operations. *) let stat_function venv pos file f = let pos = string_pos "stat_function" pos in let file = filename_of_string venv pos file in let stat = try Some (Unix.LargeFile.stat file) with Unix.Unix_error _ -> None in f stat let stat_function2 venv pos file1 file2 f = stat_function venv pos file1 (fun stat1 -> stat_function venv pos file2 (fun stat2 -> f stat1 stat2)) (* * Stat analysis. *) let file_exists stat = stat <> None let is_block_special stat = match stat with Some { Unix.LargeFile.st_kind = Unix.S_BLK ; _} -> true | _ -> false let is_char_special stat = match stat with Some { Unix.LargeFile.st_kind = Unix.S_CHR ; _} -> true | _ -> false let is_dir stat = match stat with Some { Unix.LargeFile.st_kind = Unix.S_DIR ; _} -> true | _ -> false let is_reg_file stat = match stat with Some { Unix.LargeFile.st_kind = Unix.S_REG ; _} -> true | _ -> false let is_symlink_file stat = match stat with Some { Unix.LargeFile.st_kind = Unix.S_LNK ; _} -> true | _ -> false let is_socket_file stat = match stat with Some { Unix.LargeFile.st_kind = Unix.S_SOCK ; _} -> true | _ -> false let is_named_pipe_file stat = match stat with Some { Unix.LargeFile.st_kind = Unix.S_FIFO ; _} -> true | _ -> false let is_sticky_file stat = match stat with Some { Unix.LargeFile.st_perm = perm ; _} -> perm land 0o1000 <> 0 | None -> false let is_setgid_file stat = match stat with Some { Unix.LargeFile.st_perm = perm ; _} -> perm land 0o2000 <> 0 | None -> false let is_setuid_file stat = match stat with Some { Unix.LargeFile.st_perm = perm ; _} -> perm land 0o4000 <> 0 | None -> false let is_group_owner_file stat = match stat with Some { Unix.LargeFile.st_gid = gid ; _} -> gid = Unix.getegid () | None -> false let is_owner_file stat = match stat with Some { Unix.LargeFile.st_uid = uid ; _} -> uid = Unix.geteuid () | None -> false let is_readable_file stat = match stat with Some { Unix.LargeFile.st_uid = uid; Unix.LargeFile.st_gid = gid; Unix.LargeFile.st_perm = perm; _ } -> let my_uid = Unix.geteuid () in let my_gid = Unix.getegid () in (my_uid = uid && perm land 0o400 <> 0) || (my_gid = gid && perm land 0o040 <> 0) || (perm land 0o004 <> 0) | None -> false let is_writable_file stat = match stat with Some { Unix.LargeFile.st_uid = uid; Unix.LargeFile.st_gid = gid; Unix.LargeFile.st_perm = perm; _ } -> let my_uid = Unix.geteuid () in let my_gid = Unix.getegid () in (my_uid = uid && perm land 0o200 <> 0) || (my_gid = gid && perm land 0o020 <> 0) || (perm land 0o002 <> 0) | None -> false let is_executable_file stat = match stat with Some { Unix.LargeFile.st_uid = uid; Unix.LargeFile.st_gid = gid; Unix.LargeFile.st_perm = perm; _ } -> let my_uid = Unix.geteuid () in let my_gid = Unix.getegid () in (my_uid = uid && perm land 0o100 <> 0) || (my_gid = gid && perm land 0o010 <> 0) || (perm land 0o001 <> 0) | None -> false let is_nonempty_file stat = match stat with Some { Unix.LargeFile.st_size = size ; _} -> size <> Int64.zero | None -> false (* * Binary stat operations. *) let eq_file = if Sys.os_type = "Win32" then (fun venv pos file1 file2 -> let file1 = filename_of_string venv pos file1 in let file2 = filename_of_string venv pos file2 in file1 = file2) else (fun venv pos file1 file2 -> let pos = string_pos "eq_file" pos in stat_function2 venv pos file1 file2 (fun stat1 stat2 -> match stat1, stat2 with Some { Unix.LargeFile.st_dev = dev1; Unix.LargeFile.st_ino = ino1 ; _}, Some { Unix.LargeFile.st_dev = dev2; Unix.LargeFile.st_ino = ino2 ; _} -> dev1 = dev2 && ino1 = ino2 | _ -> false)) let newer_than_file stat1 stat2 = match stat1, stat2 with Some { Unix.LargeFile.st_mtime = mtime1 ; _}, Some { Unix.LargeFile.st_mtime = mtime2 ; _} -> mtime1 > mtime2 | _ -> false let older_than_file stat1 stat2 = match stat1, stat2 with Some { Unix.LargeFile.st_mtime = mtime1 ; _}, Some { Unix.LargeFile.st_mtime = mtime2 ; _} -> mtime1 < mtime2 | _ -> false (************************************************************************ * Term evaluation. *) (* * Evaluators. *) let eval_string_exp venv pos arg = match arg with TokCurrentFile _ -> Omake_value.string_of_value venv pos (Omake_env.venv_get_var venv pos Omake_var.braces_var) | _ -> string_of_token arg let eval_int_exp _ _ arg = match arg with IntExp arg -> int_of_token arg | LengthExp arg -> length_of_token arg (* * Interpret a unary operator. *) let eval_unop_exp venv pos op arg = let pos = string_pos "unop" pos in let arg = eval_string_exp venv pos arg in match op with IsEmptyStringOp -> arg = "" | IsNonEmptyStringOp -> arg <> "" | IsBlockSpecialFileOp -> stat_function venv pos arg is_block_special | IsCharSpecialFileOp -> stat_function venv pos arg is_char_special | IsDirFileOp -> stat_function venv pos arg is_dir | ExistsFileOp -> stat_function venv pos arg file_exists | IsRegFileOp -> stat_function venv pos arg is_reg_file | IsSetgidFileOp -> stat_function venv pos arg is_setgid_file | IsSymlinkFileOp -> stat_function venv pos arg is_symlink_file | IsGroupOwnerFileOp -> stat_function venv pos arg is_group_owner_file | IsStickyFileOp -> stat_function venv pos arg is_sticky_file | IsOwnerFileOp -> stat_function venv pos arg is_owner_file | IsNamedPipeOp -> stat_function venv pos arg is_named_pipe_file | IsReadableFileOp -> stat_function venv pos arg is_readable_file | IsNonemptyFileOp -> stat_function venv pos arg is_nonempty_file | IsSocketFileOp -> stat_function venv pos arg is_socket_file | IsSetuidFileOp -> stat_function venv pos arg is_setuid_file | IsWritableFileOp -> stat_function venv pos arg is_writable_file | IsExecutableFileOp -> stat_function venv pos arg is_executable_file (* * Binary operation. *) let eval_binop_exp venv pos op e1 e2 = let pos = string_pos "binop" pos in let left = eval_string_exp venv pos e1 in let right = eval_string_exp venv pos e2 in match op with EqStringOp -> left = right | NeStringOp -> left <> right | EqFileOp -> eq_file venv pos left right | NtFileOp -> stat_function2 venv pos left right newer_than_file | OtFileOp -> stat_function2 venv pos left right older_than_file (* * Integer operations. *) let eval_intop_exp venv pos op e1 e2 = let i = eval_int_exp venv pos e1 in let j = eval_int_exp venv pos e2 in match op with EqIntOp -> i = j | GeIntOp -> i >= j | GtIntOp -> i > j | LeIntOp -> i <= j | LtIntOp -> i < j | NeIntOp -> i <> j (* * Match against the regular expression. *) let eval_match_exp venv pos regex = let basename = match Omake_env.venv_get_var venv pos Omake_var.braces_var with ValNode node -> Omake_node.Node.tail node | v -> Filename.basename (Omake_value.string_of_value venv pos v) in Lm_lexer.LmStr.string_match regex basename 0 (* * General evaluator. *) let rec eval_bool_exp venv pos e = match e with | UnopExp (op, e) -> eval_unop_exp venv pos op e | MatchExp regex -> eval_match_exp venv pos regex | BinopExp (op, e1, e2) -> eval_binop_exp venv pos op e1 e2 | IntopExp (op, e1, e2) -> eval_intop_exp venv pos op e1 e2 | NotExp e -> not (eval_bool_exp venv pos e) | AndExp (e1, e2) -> eval_bool_exp venv pos e1 && eval_bool_exp venv pos e2 | OrExp (e1, e2) -> eval_bool_exp venv pos e1 || eval_bool_exp venv pos e2 (************************************************************************ * Expression parsing. *) (* * Integer operation. *) let parse_intop op i right = let j, tokens = match right with TokLengthOp _ :: right :: tokens -> LengthExp right, tokens | right :: tokens -> IntExp right, tokens | [] -> raise (Invalid_argument "Omake_builtin_string.intop") in IntopExp (op, i, j), tokens (* * A term can be: * ! term * ( exp ) * -l string intop int * int intop int * string binop string * unop string * string *) let no_glob_options = Lm_glob.create_options [] let rec parse_term venv pos tokens = let pos = string_pos "parse_term" pos in match tokens with TokNot _ :: tokens -> let e, tokens = parse_term venv pos tokens in NotExp e, tokens | TokLeftParen _ :: tokens -> let e, tokens = parse_exp venv pos tokens in let tokens = match tokens with TokRightParen _ :: tokens -> tokens | tok :: _ -> raise (Failure ("')' expected: found " ^ string_of_token tok)) | [] -> raise (Failure "')' expected") in e, tokens | TokLengthOp _ :: left :: TokIntop (op, _) :: ((_ :: _) as right) -> parse_intop op (LengthExp left) right | left :: TokIntop (op, _) :: ((_ :: _) as right) -> parse_intop op (IntExp left) right | left :: TokBinop (op, _) :: right :: tokens -> BinopExp (op, left, right), tokens | TokUnop (op, _) :: arg :: tokens -> UnopExp (op, arg), tokens | TokName _ :: arg :: tokens -> MatchExp (Lm_glob.regex_of_shell_pattern no_glob_options (string_of_token arg)), tokens | TokRegex _ :: arg :: tokens -> MatchExp (Lm_lexer.LmStr.regexp (string_of_token arg)), tokens | arg :: tokens -> UnopExp (IsNonEmptyStringOp, arg), tokens | [] -> raise (Failure "argument expected") (* * And has higher precedence that or. *) and parse_and venv pos tokens = let pos = string_pos "parse_and" pos in let rec parse e1 tokens = match tokens with TokAnd _ :: tokens -> let e2, tokens = parse_term venv pos tokens in parse (AndExp (e1, e2)) tokens | _ -> e1, tokens in let e1, tokens = parse_term venv pos tokens in parse e1 tokens and parse_or venv pos tokens = let pos = string_pos "parse_or" pos in let rec parse e1 tokens = match tokens with TokOr _ :: tokens -> let e2, tokens = parse_and venv pos tokens in parse (OrExp (e1, e2)) tokens | _ -> e1, tokens in let e1, tokens = parse_and venv pos tokens in parse e1 tokens (* * Evaluate an entire expression. *) and parse_exp venv pos tokens = let pos = string_pos "parse" pos in parse_or venv pos tokens (************************************************************************ * Usage. * * \begin{doc} * \fun{test} * * \begin{verbatim} * test(exp) : Bool * exp : String Sequence * \end{verbatim} * * The \emph{expression} grammar is as follows: * * \begin{itemize} * \item \verb+!+ \emph{expression} : \emph{expression} is not true * \item \emph{expression1} \verb+-a+ \emph{expression2} : both expressions are true * \item \emph{expression1} \verb+-o+ \emph{expression2} : at least one expression is true * \item \verb+(+ \emph{expression} \verb+)+ : \emph{expression} is true * \end{itemize} * * The base expressions are: * * \begin{itemize} * \item \verb+-n+ \emph{string} : The \emph{string} has nonzero length * \item \verb+-z+ \emph{string} : The \emph{string} has zero length * \item \emph{string} \verb+=+ \emph{string} : The strings are equal * \item \emph{string} \verb+!=+ \emph{string} : The strings are not equal * * \item \emph{int1} \verb+-eq+ \emph{int2} : The integers are equal * \item \emph{int1} \verb+-ne+ \emph{int2} : The integers are not equal * \item \emph{int1} \verb+-gt+ \emph{int2} : \emph{int1} is larger than \emph{int2} * \item \emph{int1} \verb+-ge+ \emph{int2} : \emph{int2} is not larger than \emph{int1} * \item \emph{int1} \verb+-lt+ \emph{int2} : \emph{int1} is smaller than \emph{int2} * \item \emph{int1} \verb+-le+ \emph{int2} : \emph{int1} is not larger than \emph{int2} * * \item \emph{file1} \verb+-ef+ \emph{file2} : On Unix, \emph{file1} and \emph{file2} have the * same device and inode number. * On Win32, \emph{file1} and \emph{file2} have the * same name. * \item \emph{file1} \verb+-nt+ \emph{file2} : \emph{file1} is newer than \emph{file2} * \item \emph{file1} \verb+-ot+ \emph{file2} : \emph{file1} is older than \emph{file2} * * \item \verb+-b+ \emph{file} : The file is a block special file * \item \verb+-c+ \emph{file} : The file is a character special file * \item \verb+-d+ \emph{file} : The file is a directory * \item \verb+-e+ \emph{file} : The file exists * \item \verb+-f+ \emph{file} : The file is a normal file * \item \verb+-g+ \emph{file} : The set\verb+-group+\verb+-id+ bit is set on the file * \item \verb+-G+ \emph{file} : The file's group is the current effective group * \item \verb+-h+ \emph{file} : The file is a symbolic link (also \verb+-L+) * \item \verb+-k+ \emph{file} : The file's sticky bit is set * \item \verb+-L+ \emph{file} : The file is a symbolic link (also \verb+-h+) * \item \verb+-O+ \emph{file} : The file's owner is the current effective user * \item \verb+-p+ \emph{file} : The file is a named pipe * \item \verb+-r+ \emph{file} : The file is readable * \item \verb+-s+ \emph{file} : The file has a non-zero size * \item \verb+-S+ \emph{file} : The file is a socket * \item \verb+-u+ \emph{file} : The set\verb+-user+\verb+-id+ bit is set on the file * \item \verb+-w+ \emph{file} : The file is writable * \item \verb+-x+ \emph{file} : The file is executable * \end{itemize} * * A \emph{string} is any sequence of characters; leading \verb+-+ characters are allowed. * * An \emph{int} is a \emph{string} that can be interpreted as an integer. Unlike traditional * versions of the test program, the leading characters may specify an arity. The * prefix \verb+0b+ means the numbers is in binary; the prefix \verb+0o+ means * the number is in octal; the prefix \verb+0x+ means the number is in hexadecimal. * An \emph{int} can also be specified as \verb+-l+ \emph{string}, which evaluates to the length of * the \emph{string}. * * A \emph{file} is a \emph{string} that represents the name of a file. * * The syntax mirrors that of the \Cmd{test}{1} program. If you are on a Unix system, the man page * explains more. Here are some examples. * * \begin{verbatim} * # Create an empty file * osh> touch foo * # Is the file empty? * osh> test(-e foo) * - : true * osh> test(! -e foo) * - : false * # Create another file * osh> touch boo * # Is the newer file newer? * osh> test(boo -nt foo) * - : true * # A more complex query * # boo is newer than foo, and foo is empty * osh> test(\( boo -nt foo \) -a -e foo) * - : true * \end{verbatim} * \end{doc} *) let print_usage venv pos loc = let outv = Omake_env.venv_find_var venv pos loc Omake_var.stderr_var in let outx = Omake_value.channel_of_value venv pos outv in Lm_channel.output_string outx "test \nFor usage, see the omake manual\n"; false let print_version venv pos loc = let outv = Omake_env.venv_find_var venv pos loc Omake_var.stdout_var in let outx = Omake_value.channel_of_value venv pos outv in Lm_channel.output_string outx "test version 1.0.0\n"; false (* * Evaluate the expression. *) let test_exp venv pos tokens = let pos = string_pos "test_exp" pos in let tokens = List.map token_of_string tokens in let e, tokens = parse_exp venv pos tokens in match tokens with [] -> eval_bool_exp venv pos e | tok :: _ -> raise (Failure ("unexpected token: " ^ string_of_token tok)) (* * Parse the command line. *) let test_cmd_exn venv pos loc argv = match argv with ["["; "--help"] -> print_usage venv pos loc | ["["; "--version"] -> print_version venv pos loc | "[" :: argv -> let argv, delim = split_last argv in if delim = "]" then test_exp venv pos argv else print_usage venv pos loc | _ :: argv -> test_exp venv pos argv | [] -> false let test_cmd venv pos loc argv = try test_cmd_exn venv pos loc argv with Failure _ as exn -> raise (Omake_value_type.UncaughtException (loc_pos loc pos, exn)) (************************************************************************ * Usage. * * \begin{doc} * \fun{find} * * \begin{verbatim} * find(exp) : Node Array * exp : String Sequence * \end{verbatim} * * The \verb+find+ function searches a directory recursively, returning the * files for which the expression evaluates to true. * * The expression argument uses the same syntax as the \verb+test+ function, * with the following exceptions. * * \begin{enumerate} * \item The expression may begin with a directory. If not specified, the current * directory is searched. * \item The \verb+{}+ string expands to the current file being examined. * \end{enumerate} * * The syntax of the expression is the same as \verb+test+, with the following * additions. * * \begin{itemize} * \item \verb+-name+ \emph{string} : The current file matches the glob expression * (see Section~\ref{section:globbing}). * \item \verb+-regex+ \emph{string} : The current file matches the regular expression * \end{itemize} * * The \verb+find+ function performs a recursive scan of all subdirectories. * The following call is being run from the root of the \verb+omake+ source directory. * * \begin{verbatim} * osh> find(. -name fo* ) * - : * \end{verbatim} * * Another example, listing only those files that are normal files * or symbolic links. * * \begin{verbatim} * osh> find(. -name fo* -a \( -f {} -o -L {} \)) * - : * \end{verbatim} * \end{doc} *) let test venv pos loc args = let pos = string_pos "test" pos in let code = match args with [arg] -> let argv = "test" :: Omake_value.strings_of_value venv pos arg in test_cmd venv pos loc argv | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in Omake_builtin_util.val_of_bool code let shell_test cmd venv pos loc args = let pos = string_pos "shell-test" pos in let code = match args with [arg] -> let argv = cmd :: Omake_value.strings_of_value venv pos arg in test_cmd venv pos loc argv | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in if code then Omake_builtin_util.val_true else raise (Omake_value_type.ExitException (pos, 1)) (************************************************************************ * Find function. *) (* * Walk the directory tree, testing for files. *) let rec find_file venv pos nodes name e = (* Convert the name to to a value *) let v = Omake_value.node_value_of_value venv pos ~follow_symlinks:false (ValString name) in (* Add this node if the expression matches *) let nodes = let venv = Omake_env.venv_add_var venv Omake_var.braces_var v in if eval_bool_exp venv pos e then v :: nodes else nodes in (* If this is a directory, then walk it recursively *) match v with ValDir dir -> let dirname = Omake_node.Dir.fullname dir in let names = try Array.to_list @@ Sys.readdir dirname with Sys_error _ -> [] in List.fold_left (fun nodes name' -> let filename = Filename.concat name name' in find_file venv pos nodes filename e) nodes names | _ -> nodes (* * The main function, from arguments. *) let find_top venv pos _ arg = let argv = Omake_value.strings_of_value venv pos arg in let tokens = List.map token_of_string argv in let dir, tokens = match tokens with TokString s :: tokens -> s, tokens | _ -> ".", tokens in let e, tokens = parse_exp venv pos tokens in let () = match tokens with [] -> () | tok :: _ -> raise (Failure ("unexpected token: " ^ string_of_token tok)) in List.rev (find_file venv pos [] dir e) (* * Find function. *) let find venv pos loc args = let pos = string_pos "find" pos in match args with [arg] -> let nodes = find_top venv pos loc arg in Omake_value.concat_array nodes | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let shell_find venv pos loc args = let pos = string_pos "find" pos in match args with | [arg] -> let stdout_fd = Omake_env.venv_find_var venv pos loc Omake_var.stdout_var in let outp, _ = Omake_value.out_channel_of_any_value venv pos stdout_fd in let outx = Omake_env.venv_find_channel venv pos outp in let nodes = find_top venv pos loc arg in List.iter (fun node -> Lm_channel.output_string outx (Omake_value.string_of_value venv pos node); Lm_channel.output_string outx "\n") nodes; Lm_channel.flush outx; Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (************************************************************************ * External interface. *) let () = let builtin_funs = [true, "test", test, Omake_ir.ArityExact 1; true, "builtin-test", shell_test "test", ArityExact 1; true, "builtin-test-brack", shell_test "[", ArityExact 1; true, "find", find, ArityExact 1; true, "builtin-find", shell_find, ArityExact 1] in let builtin_info = { Omake_builtin_type.builtin_empty with builtin_funs = builtin_funs } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_builtin_fun.ml0000644000175000017500000000736713177364666017634 0ustar gerdgerd(* * Functions and application. * * \begin{doc} * \section{First-class functions} * \end{doc} *) include Omake_pos.Make (struct let name = "Omake_builtin_fun" end) (* * Anonymous functions. * * \section{Functions} * * \begin{doc} * \fun{fun} * * The \verb+fun+ form introduces anonymous functions. * * \verb+$(fun , ..., => )+ * * The last argument is the body of the function. * The other arguments are the parameter names. * * The three following definitions are equivalent. * * \begin{verbatim} * F(X, Y) = * return($(addsuffix $(Y), $(X))) * * F = $(fun X, Y => $(addsuffix $(Y), $(X))) * * F = * fun(X, Y) => * value $(addsuffix $(Y), $(X)) * \end{verbatim} * \end{doc} *) let fun_fun _ pos loc args = let pos = string_pos "fun" pos in match args with [arg] -> arg | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * Function application. * * \begin{doc} * \fun{apply} * * The \verb+apply+ operator is used to apply a function. * * \verb+$(apply , )+ * * Suppose we have the following function definition. * * \begin{verbatim} * F(X, Y) = * return($(addsuffix $(Y), $(X))) * \end{verbatim} * * The the two expressions below are equivalent. * * \begin{verbatim} * X = F(a b c, .c) * X = $(apply $(F), a b c, .c) * \end{verbatim} * * The \verb+apply+ form can also be used for partial applications, * where a function is passed fewer arguments than it expects. The * result is a function that takes the remaining arguments, * and calls the function with the full set of arguments. * * \begin{verbatim} * add2(i, j) = * add($i, $j) * succ = $(apply $(add2), 1) * i = $(succ 5) # Computes 1+5 * \end{verbatim} * \end{doc} *) let apply_fun venv pos loc args kargs = let pos = string_pos "apply" pos in let fun_val, args = match args with fun_val :: args -> fun_val, args | [] -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, 0))) in Omake_eval.eval_partial_apply venv pos loc fun_val args kargs (* * Function application. * * \begin{doc} * \fun{applya} * * The \verb+applya+ operator is used to apply a function to * an array of arguments. * * \verb+$(applya , )+ * * For example, in the following program, the value * of \verb+Z+ is \verb+file.c+. * * \begin{verbatim} * F(X, Y) = * return($(addsuffix $(Y), $(X))) * args[] = * file * .c * Z = $(applya $(F), $(args)) * \end{verbatim} * * The \verb+applya+ form can also be used for partial applications. * \end{doc} *) let applya_fun venv pos loc args kargs = let pos = string_pos "applya" pos in let fun_val, args = match args with [fun_val; args] -> fun_val, args | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, 0))) in let args = Omake_value.values_of_value venv pos args in Omake_eval.eval_partial_apply venv pos loc fun_val args kargs (************************************************************************ * Tables. *) let () = let builtin_funs = [false, "fun", fun_fun, Omake_ir.ArityExact 1] in let builtin_kfuns = [true, "apply", apply_fun, Omake_ir.ArityAny; true, "applya", applya_fun, ArityAny; ] in let builtin_info = {Omake_builtin_type.builtin_empty with builtin_funs = builtin_funs; builtin_kfuns = builtin_kfuns } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_builtin_sys.ml0000644000175000017500000004251713177364666017656 0ustar gerdgerdinclude Omake_pos.Make (struct let name = "Omake_builtin_sys" end);; (************************************************************************ * Passwd database access. *) (* * \begin{doc} * \obj{Passwd} * * The \verb+Passwd+ object represents an entry in the system's user database. * It contains the following fields. * * \begin{description} * \itemidx{pw\_name}: the login name. * \itemidx{pw\_passwd}: the encrypted password. * \itemidx{pw\_uid}: user id of the user. * \itemidx{pw\_gid}: group id of the user. * \itemidx{pw\_gecos}: the user name or comment field. * \itemidx{pw\_dir}: the user's home directory. * \itemidx{pw\_shell}: the user's default shell. * \end{description} * * Not all the fields will have meaning on all operating systems. * * \twofuns{getpwnam}{getpwuid} * * \begin{verbatim} * $(getpwnam name...) : Passwd * name : String * $(getpwuid uid...) : Passwd * uid : Int * raises RuntimeException * \end{verbatim} * * The \verb+getpwnam+ function looks up an entry by the user's login and the \verb+getpwuid+ * function looks up an entry by user's numerical id (uid). If no entry is found, an exception * will be raised. * * \fun{getpwents} * * \begin{verbatim} * $(getpwents) : Array * \end{verbatim} * * The \verb+getpwents+ function returns an array of \verb+Passwd+ objects, one for every user * fund in the system user database. Note that depending on the operating system and on the setup * of the user database, the returned array may be incomplete or even empty. * \end{doc} *) let create_passwd_obj obj passwd = let obj = Omake_env.venv_add_field_internal obj Omake_symbol.pw_name_sym (ValString passwd.Unix.pw_name) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.pw_passwd_sym (ValString passwd.Unix.pw_passwd) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.pw_uid_sym (ValInt passwd.Unix.pw_uid) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.pw_gid_sym (ValInt passwd.Unix.pw_gid) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.pw_gecos_sym (ValString passwd.Unix.pw_gecos) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.pw_dir_sym (ValString passwd.Unix.pw_dir) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.pw_shell_sym (ValString passwd.Unix.pw_shell) in Omake_value_type.ValObject obj let getpwnam venv pos loc args = let pos = string_pos "getpwnam" pos in let obj = Omake_env.venv_find_object_or_empty venv Omake_var.passwd_object_var in let user = match args with [user] -> Omake_eval.string_of_value venv pos user | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let passwd = try Unix.getpwnam user with Not_found -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("unknown user", user))) in create_passwd_obj obj passwd let getpwuid venv pos loc args = let pos = string_pos "getpwuid" pos in let obj = Omake_env.venv_find_object_or_empty venv Omake_var.passwd_object_var in let uid = match args with [uid] -> Omake_value.int_of_value venv pos uid | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let passwd = try Unix.getpwuid uid with Not_found -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("unknown uid", uid))) in create_passwd_obj obj passwd let getpwents venv _pos _loc _args = let obj = Omake_env.venv_find_object_or_empty venv Omake_var.passwd_object_var in let ents = List.map (create_passwd_obj obj) (Lm_unix_util.getpwents ()) in Omake_value_type.ValArray ents (************************************************************************ * Group database access. *) (* * \begin{doc} * \obj{Group} * * The \verb+Group+ object represents an entry in the system's user group database. * It contains the following fields. * * \begin{description} * \itemidx{gr\_name}: the group name. * \itemidx{gr\_group}: the encrypted password. * \itemidx{gr\_gid}: group id of the group. * \itemidx{gr\_mem}: the group member's user names. * \end{description} * * Not all the fields will have meaning on all operating systems. * * \twofuns{getgrnam}{getgrgid} * * \begin{verbatim} * $(getgrnam name...) : Group * name : String * $(getgrgid gid...) : Group * gid : Int * raises RuntimeException * \end{verbatim} * * The \verb+getgrnam+ function looks up a group entry by the group's name and the \verb+getgrgid+ * function looks up an entry by groups's numerical id (gid). If no entry is found, an exception * will be raised. * * \end{doc} *) let create_group_obj obj group = let gr_mem = Array.fold_right (fun s x -> Omake_value_type.ValString s::x) group.Unix.gr_mem [] in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.gr_name_sym (ValString group.Unix.gr_name) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.gr_passwd_sym (ValString group.Unix.gr_passwd) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.gr_gid_sym (ValInt group.Unix.gr_gid) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.gr_mem_sym (ValArray gr_mem) in Omake_value_type.ValObject obj let getgrnam venv pos loc args = let pos = string_pos "getgrnam" pos in let obj = Omake_env.venv_find_object_or_empty venv Omake_var.group_object_var in let user = match args with [user] -> Omake_eval.string_of_value venv pos user | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let group = try Unix.getgrnam user with Not_found -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringStringError ("unknown user", user))) in create_group_obj obj group let getgrgid venv pos loc args = let pos = string_pos "getgruid" pos in let obj = Omake_env.venv_find_object_or_empty venv Omake_var.group_object_var in let gid = match args with [gid] -> Omake_value.int_of_value venv pos gid | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let group = try Unix.getgrgid gid with Not_found -> raise (Omake_value_type.OmakeException (loc_pos loc pos, StringIntError ("unknown gid", gid))) in create_group_obj obj group (* * \begin{doc} * \fun{tgetstr} * * \begin{verbatim} * $(tgetstr id) : String * id : String * \end{verbatim} * * The \verb+tgetstr+ function looks up the terminal capability with the indicated \verb+id+. * This assumes the terminfo to lookup is given in the \verb+TERM+ environment variable. This * function returns an empty value if the given terminal capability is not defined. * * Note: if you intend to use the value returned by \verb+tgetstr+ inside the shell * \hypervarn{prompt}, you need to wrap it using the \hyperfun{prompt-invisible}. * \end{doc} *) let tgetstr venv pos loc args = let pos = string_pos "tgetstr" pos in match args with [arg] -> begin match Lm_terminfo.tgetstr (Omake_eval.string_of_value venv pos arg) with Some s -> Omake_value_type.ValData s | None -> ValNone end | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let str_wrap name f v _ pos loc args = let pos = string_pos name pos in if args <> [] then raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 0, List.length args))) else match f v with Some s -> Omake_value_type.ValData s | None -> ValNone (* * \begin{doc} * \twofuns{xterm-escape-begin}{xterm-escape-end} * * \begin{verbatim} * $(xterm-escape-begin) : String * $(xterm-escape-end) : String * \end{verbatim} * * The \verb+xterm-escape-begin+ and \verb+xterm-escape-end+ functions return the escape sequences * that can be used to set the XTerm window title. Will return empty values if this capability is * not available. * * Note: if you intend to use these strings inside the shell \hypervarn{prompt}, you need to use * \verb+$(prompt_invisible_begin)$(xterm-escape-begin)+ and * \verb+$(xterm-escape-end)$(prompt_invisible_end)+. * \end{doc} *) let xterm_escape_begin = str_wrap "xterm-escape-begin" Lm_terminfo.xterm_escape_begin () let xterm_escape_end = str_wrap "xterm-escape-end" Lm_terminfo.xterm_escape_end () (* * \begin{doc} * \fun{xterm-escape} * * \begin{verbatim} * $(xterm-escape s) : Sequence * \end{verbatim} * * When the \verb+TERM+ environment variable indicates that the XTerm title setting capability is available, * \verb+$(xterm-escape s)+ is equivalent to \verb+$(xterm-escape-begin)s$(xterm-escape-end)+. Otherwise, it * returns an empty value. * * Note: if you intend to use the value returned by \verb+xterm-escape+ inside the shell * \hypervarn{prompt}, you need to wrap it using the \hyperfun{prompt-invisible}. * \end{doc} * * Implemented in Pervasives.om *) (* * \begin{doc} * \twofuns{prompt-invisible-begin}{prompt-invisible-end} * * \begin{verbatim} * $(prompt-invisible-begin) : String * $(prompt-invisible-end) : String * \end{verbatim} * * The \verb+prompt-invisible-begin+ and \verb+prompt-invisible-end+ functions return the escape sequences * that must used to mark the ``invisible'' sections of the shell \hypervarn{prompt} (such as various escape sequences). * \end{doc} *) let opt_wrap f = function Some x -> Some (f x) | None -> None let prompt_invisible_begin = str_wrap "prompt-invisible-begin" (opt_wrap fst) Lm_readline.prompt_invisible let prompt_invisible_end = str_wrap "prompt-invisible-end" (opt_wrap snd) Lm_readline.prompt_invisible (* * \begin{doc} * \fun{prompt-invisible} * * \begin{verbatim} * $(prompt-invisible s) : Sequence * \end{verbatim} * * The \verb+prompt-invisible+ will wrap its argument with \verb+$(prompt-invisible-begin)+ and * \verb+$(prompt-invisible-end)+. All the `invisible'' sections of the shell \hypervarn{prompt} (such as various * escape sequences) must be wrapped this way. * \end{doc} * * Implemented in Pervasives.om *) (* * \begin{doc} * \fun{gettimeofday} * * \begin{verbatim} * $(gettimeofday) : Float * \end{verbatim} * * The \verb+gettimeofday+ function returns the time of day in seconds * since January 1, 1970. * * \end{doc} *) let gettimeofday _ pos loc args = let pos = string_pos "gettimeofday" pos in match args with [] -> Omake_value_type.ValFloat (Unix.gettimeofday ()) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 0, List.length args))) (* * \begin{doc} * \obj{Tm} * The \verb+Tm+ object is a structure that represents the time and date. * * \begin{description} * \itemidx{tm\_sec} \verb+: Int+ Seconds (0--59). * \itemidx{tm\_min} \verb+: Int+ Minutes (0--59). * \itemidx{tm\_hour} \verb+: Int+ Hours (0--23). * \itemidx{tm\_mday} \verb+: Int+ Day of the month (0--31). * \itemidx{tm\_mon} \verb+: Int+ Month (0--11). * \itemidx{tm\_year} \verb+: Int+ Year (minus 1900). * \itemidx{tm\_wday} \verb+: Int+ Day of the week (0--6, Sunday is 0). * \itemidx{tm\_yday} \verb+: Int+ Day of the year (0--365). * \itemidx{tm\_isdst} \verb+: Bool+ True iff daylight savings time is in effect. * \end{description} * * \twofuns{gmtime}{localtime} * \begin{verbatim} * $(gmtime time) : tm * $(localtime time) : tm * time : Float * \end{verbatim} * * Convert the time in seconds since the Unix epoch to calendar format. * The function \verb+gmtime+ assumes UTC (Coordinated Universal Time); * the function \verb+localtime+ uses the local time zone. * \end{doc} *) let tm_object venv info = let obj = Omake_env.venv_find_object_or_empty venv Omake_var.tm_object_var in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.tm_sec_sym (ValInt info.Unix.tm_sec) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.tm_min_sym (ValInt info.Unix.tm_min) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.tm_hour_sym (ValInt info.Unix.tm_hour) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.tm_mday_sym (ValInt info.Unix.tm_mday) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.tm_mon_sym (ValInt info.Unix.tm_mon) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.tm_year_sym (ValInt info.Unix.tm_year) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.tm_wday_sym (ValInt info.Unix.tm_wday) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.tm_yday_sym (ValInt info.Unix.tm_yday) in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.tm_isdst_sym (if info.Unix.tm_isdst then Omake_builtin_util.val_true else Omake_builtin_util.val_false) in obj let gmtime venv pos loc args = let pos = string_pos "gmtime" pos in match args with [now] -> let info = Unix.gmtime (Omake_value.float_of_value venv pos now) in Omake_value_type.ValObject (tm_object venv info) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) let localtime venv pos loc args = let pos = string_pos "gmtime" pos in match args with [now] -> let info = Unix.localtime (Omake_value.float_of_value venv pos now) in Omake_value_type.ValObject (tm_object venv info) | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) (* * \begin{doc} * \twofuns{mktime}{normalize-time} * \begin{verbatim} * $(mktime tm) : Float * $(normalize-time tm) : Tm * tm : Tm * \end{verbatim} * * Convert the calendar time to time in seconds since the Unix epoch. * Assumes the local time zone. * * The fields \verb+tm_wday+, \verb+tm_mday+, \verb+tm_yday+ are ignored. * The other components are not restricted to their normal ranges and will be * normalized as needed. * * The function \verb+normalize-time+ normalizes the * calendar time. The returned object contains an additional field * \verb+tm_time : Float+ that represnets the time in seconds since the Unix epoch * (the same value returned by \verb+mktime+). * \end{doc} *) let mktime_aux select venv pos loc args = let pos = string_pos "mktime" pos in let obj = match args with [obj] -> Omake_eval.eval_object venv pos obj | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 1, List.length args))) in let info = { Unix.tm_sec = Omake_value.int_of_value venv pos (Omake_env.venv_find_field_internal obj pos Omake_symbol.tm_sec_sym); Unix.tm_min = Omake_value.int_of_value venv pos (Omake_env.venv_find_field_internal obj pos Omake_symbol.tm_min_sym); Unix.tm_hour = Omake_value.int_of_value venv pos (Omake_env.venv_find_field_internal obj pos Omake_symbol.tm_hour_sym); Unix.tm_mday = Omake_value.int_of_value venv pos (Omake_env.venv_find_field_internal obj pos Omake_symbol.tm_mday_sym); Unix.tm_mon = Omake_value.int_of_value venv pos (Omake_env.venv_find_field_internal obj pos Omake_symbol.tm_mon_sym); Unix.tm_year = Omake_value.int_of_value venv pos (Omake_env.venv_find_field_internal obj pos Omake_symbol.tm_year_sym); Unix.tm_wday = Omake_value.int_of_value venv pos (Omake_env.venv_find_field_internal obj pos Omake_symbol.tm_wday_sym); Unix.tm_yday = Omake_value.int_of_value venv pos (Omake_env.venv_find_field_internal obj pos Omake_symbol.tm_yday_sym); Unix.tm_isdst = Omake_eval.bool_of_value venv pos (Omake_env.venv_find_field_internal obj pos Omake_symbol.tm_isdst_sym) } in select (Unix.mktime info) let mktime = mktime_aux (fun (secs, _) -> Omake_value_type.ValFloat secs) let normalize_tm venv pos loc args = mktime_aux (fun (secs, tm) -> let obj = tm_object venv tm in let obj = Omake_env.venv_add_field_internal obj Omake_symbol.tm_time_sym (Omake_value_type.ValFloat secs) in Omake_value_type.ValObject obj) venv pos loc args (************************************************************************ * Tables. *) let () = let builtin_funs = [ true, "gettimeofday", gettimeofday, Omake_ir.ArityExact 0; true, "getpwnam", getpwnam, ArityExact 1; true, "getpwuid", getpwuid, ArityExact 1; true, "getpwents", getpwents, ArityExact 0; true, "getgrnam", getgrnam, ArityExact 1; true, "getgrgid", getgrgid, ArityExact 1; true, "tgetstr", tgetstr, ArityExact 1; true, "xterm-escape-begin", xterm_escape_begin, ArityExact 0; true, "xterm-escape-end", xterm_escape_end, ArityExact 0; true, "prompt-invisible-begin", prompt_invisible_begin, ArityExact 0; true, "prompt-invisible-end", prompt_invisible_end, ArityExact 0; true, "gmtime", gmtime, ArityExact 1; true, "localtime", localtime, ArityExact 1; true, "mktime", mktime, ArityExact 1; true, "normalize-tm", normalize_tm, ArityExact 1; ] in let builtin_info = { Omake_builtin_type.builtin_empty with builtin_funs = builtin_funs } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_builtin_ocamldep.ml0000644000175000017500000001462213177364666020620 0ustar gerdgerd(* Experimental builtins for accelerating ocamldep postprocessing *) include Omake_pos.Make (struct let name = "Omake_builtin_ocamldep" end) open Printf open Omake_ir (* * \begin{doc} * \fun{ocamldep-print-buildable-deps} * * \begin{verbatim} * $(ocamldep-postproc path, enable_cmx) * path : Dir array * enable_cmx : Bool * \end{verbatim} * * Postprocesses an ocamldep invocation with -modules switch. * * Accesses the global \verb+EXT_OBJ+ for getting the ".o" suffix. * \end{doc} *) let target_is_buildable cache venv pos node = try Omake_target.target_is_buildable cache venv pos node with Omake_value_type.RaiseException(_, obj) when Omake_env.venv_instanceof obj Omake_symbol.unbuildable_exception_sym -> false let ocamldep_postproc venv pos loc args = let cache = Omake_env.venv_cache venv in let search_in_path path name = try let name1 = String.uncapitalize_ascii name in let name2 = String.capitalize_ascii name in let names = (* check name with orignal case first *) if name1 = name then [ name1; name2 ] else [ name2; name1 ] in let node_opt = Omake_target.target_is_buildable_in_path_1 cache venv pos path names in match node_opt with | Some node -> Some(Omake_env.venv_nodename venv node) | None -> None with | Omake_value_type.RaiseException(_, obj) when Omake_env.venv_instanceof obj Omake_symbol.unbuildable_exception_sym -> None in let accumulate_over_path path deps suffix = List.rev (List.fold_left (fun acc dep -> match search_in_path path (dep ^ suffix) with | Some node -> node :: acc | None -> acc ) [] deps ) in let pos = string_pos "ocamldep-print-buildable-deps" pos in let stdin_var = Omake_env.venv_find_var venv pos loc Omake_var.stdin_var in let stdin_prim, stdin_close_flag = Omake_value.in_channel_of_any_value venv pos stdin_var in let stdin_fd = Omake_env.venv_find_channel venv pos stdin_prim in let stdout_var = Omake_env.venv_find_var venv pos loc Omake_var.stdout_var in let stdout_prim, stdout_close_flag = Omake_value.out_channel_of_any_value venv pos stdout_var in let stdout_fd = Omake_env.venv_find_channel venv pos stdout_prim in let ext_obj_val = Omake_builtin_util.get_sym venv pos loc "EXT_OBJ" in let ext_obj = Omake_value.string_of_value venv pos ext_obj_val in let output_dep path target deps enable_cmx = let cmideps = accumulate_over_path path deps ".cmi" in let cmideps_str = String.concat " " (List.map String.escaped cmideps) in if Filename.check_suffix target ".mli" then ( let targetbase = Filename.chop_suffix target ".mli" in if cmideps <> [] then Lm_channel.output_string stdout_fd (sprintf "%s.cmi: %s\n" (String.escaped targetbase) cmideps_str ) ) else if Filename.check_suffix target ".ml" then ( let targetbase = Filename.chop_suffix target ".ml" in let targetbase_esc = String.escaped targetbase in let cmxdeps = if enable_cmx then accumulate_over_path path deps ".cmx" else [] in let alldeps = cmideps @ cmxdeps in let alldeps_str = String.concat " " (List.map String.escaped alldeps) in if cmideps <> [] || cmxdeps <> [] then ( if cmideps <> [] then Lm_channel.output_string stdout_fd (sprintf "%s.cmo: %s\n" targetbase_esc cmideps_str ); Lm_channel.output_string stdout_fd (sprintf "%s.cmx %s%s: %s\n" targetbase_esc targetbase_esc ext_obj alldeps_str ) ) ) else raise (Omake_value_type.OmakeException (loc_pos loc pos, StringError "illegal filename suffix")) in match args with | [path; enable_cmx] -> let path = Omake_value.values_of_value venv pos path in let path = Omake_eval.path_of_values venv pos path "." in let path = List.flatten (List.map snd path) in let path = List.map (fun dir -> dir, Omake_env.venv_lookup_target_dir venv dir) path in let enable_cmx = Omake_value.bool_of_value venv pos enable_cmx in let current = ref None in let process_current() = match !current with | None -> () | Some(target, deps) -> current := None; output_dep path target deps enable_cmx in ( try while true do let line = Lm_channel.input_line stdin_fd in if Lm_string_util.contains line ':' then ( process_current(); let k = Lm_string_util.strchr line ':' in let target = String.sub line 0 k in let rest = String.sub line (k+1) (String.length line - k - 1) in let words = Lm_string_util.tokens "" Lm_string_util.white rest in current := Some(target, words) ) else ( match !current with | None -> () | Some(target,words) -> let more_words = Lm_string_util.tokens "" Lm_string_util.white line in current := Some(target, words @ more_words) ) done; assert false with | End_of_file -> () ); process_current(); if stdin_close_flag then Omake_env.venv_close_channel venv pos stdin_prim; if stdout_close_flag then Omake_env.venv_close_channel venv pos stdout_prim; Omake_value_type.ValNone | _ -> raise (Omake_value_type.OmakeException (loc_pos loc pos, ArityMismatch (ArityExact 2, List.length args))) (* register *) let () = let builtin_funs = [true, "ocamldep-postproc", ocamldep_postproc, ArityExact 2; ] in let builtin_info = { Omake_builtin_type.builtin_empty with builtin_funs = builtin_funs; } in Omake_builtin.register_builtin builtin_info omake-0.10.3/src/builtin/omake_printf.mli0000644000175000017500000000214613177364666016757 0ustar gerdgerdmodule type PrintfArgsSig = sig type t type value val print_char : t -> char -> unit val print_string : t -> string -> unit val open_box : t -> int -> unit val open_hbox : t -> unit val open_vbox : t -> int -> unit val open_hvbox : t -> int -> unit val open_hovbox : t -> int -> unit val close_box : t -> unit val print_cut : t -> unit val print_space : t -> unit val force_newline : t -> unit val print_break : t -> int -> int -> unit val print_flush : t -> unit val print_newline : t -> unit val bool_of_value : t -> value -> bool val int_of_value : t -> value -> int val char_of_value : t -> value -> char val float_of_value : t -> value -> float val string_of_value : t -> value -> string val print_value : t -> value -> unit val apply1 : t -> value -> unit val apply2 : t -> value -> value -> unit val exit : t -> value list -> value end module MakePrintf : functor (Args : PrintfArgsSig) -> sig type t = Args.t type value = Args.value val fprintf : t -> string -> value list -> value end omake-0.10.3/src/builtin/omake_builtin_shell.mli0000644000175000017500000000000013177364666020275 0ustar gerdgerdomake-0.10.3/src/builtin/omake_builtin_arith.mli0000644000175000017500000000000013177364666020275 0ustar gerdgerdomake-0.10.3/src/builtin/omake_builtin_io_fun.mli0000644000175000017500000000003613177364666020456 0ustar gerdgerd val debug_parsing : bool ref omake-0.10.3/src/builtin/omake_builtin_target.mli0000644000175000017500000000000013177364666020454 0ustar gerdgerdomake-0.10.3/src/builtin/omake_builtin_object.mli0000644000175000017500000000000013177364666020434 0ustar gerdgerdomake-0.10.3/src/builtin/omake_builtin_file.mli0000644000175000017500000000000013177364666020105 0ustar gerdgerdomake-0.10.3/src/builtin/omake_builtin_base.mli0000644000175000017500000000000013177364666020100 0ustar gerdgerdomake-0.10.3/src/builtin/omake_builtin_rule.mli0000644000175000017500000000000013177364666020135 0ustar gerdgerdomake-0.10.3/src/builtin/omake_builtin_util.mli0000644000175000017500000000125013177364666020153 0ustar gerdgerd (* Run-time symbols. *) val defined_sym : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> string -> bool val get_sym : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> string -> Omake_value_type.t val add_sym : Omake_env.t -> Omake_value_type.pos -> Lm_location.t -> string -> Omake_value_type.t -> Omake_env.t (* * Map over a sequence and add separators. *) val sequence_map : ('a -> Omake_value_type.t) -> 'a list -> Omake_value_type.t list val sequence_list : Omake_value_type.t list -> Omake_value_type.t list (* * Boolean values. *) val val_true : Omake_value_type.t val val_false : Omake_value_type.t val val_of_bool : bool -> Omake_value_type.t omake-0.10.3/src/builtin/omake_builtin_test.mli0000644000175000017500000000000013177364666020145 0ustar gerdgerdomake-0.10.3/src/builtin/omake_builtin_fun.mli0000644000175000017500000000000013177364666017756 0ustar gerdgerdomake-0.10.3/src/builtin/omake_builtin_sys.mli0000644000175000017500000000000013177364666020004 0ustar gerdgerdomake-0.10.3/src/builtin/omake_builtin_io.mli0000644000175000017500000000000013177364666017575 0ustar gerdgerdomake-0.10.3/lib/0000755000175000017500000000000013177364666012104 5ustar gerdgerdomake-0.10.3/lib/OMakefile.default0000644000175000017500000000766613177364666015325 0ustar gerdgerd######################################################################## # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the # File is furnished to do so, subject to the following condition: # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, # DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR # OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE FILE OR # THE USE OR OTHER DEALINGS IN THE FILE. ######################################################################## # The standard OMakefile. # You will usually need to modify this file for your project. # Delete this line once you have configured this file eprintln($(CWD)/OMakefile is not configured) ######################################################################## # Phony targets are scoped, so you probably want to declare them first. # # .PHONY: all install clean ######################################################################## # Subdirectories. # You may want to include some subdirectories in this project. # If so, define the subdirectory targets and uncomment this section. # # .SUBDIRS: ######################################################################## # C configuration. # Delete this section if you are not building C files. # ################################################ # Configuration. You might want to modify any of these # configuration variables. # # CFLAGS += # ASFLAGS += # LDFLAGS += # INCLUDES += ################################################ # Uncomment the following section if you want # to build a C program in the current directory. # # CFILES[] = # file1 # main # # MAIN = main # # .DEFAULT: $(CProgram $(MAIN), $(CFILES)) ################################################ # Uncomment the following section if you want to build a C library # in the current directory. # # LIBFILES[] = # file1 # file2 # # LIB = libxxx # # .DEFAULT: $(StaticCLibrary $(LIB), $(LIBFILES)) ######################################################################## # OCaml configuration. # Delete this section if you are not building OCaml files. # ################################################ # Configuration. You may want to modify any of these configuration # variables. # # # This project requires ocamlfind (default - false). # # USE_OCAMLFIND = true # # OCAMLPACKS[] = # pack1 # pack2 # # if $(not $(OCAMLFIND_EXISTS)) # eprintln(This project requires ocamlfind, but is was not found.) # eprintln(You need to install ocamlfind and run "omake --configure".) # exit 1 # # Include path # # OCAMLINCLUDES += # # Compile native or byte code? # # The default values are defined as follows: # # NATIVE_ENABLED = $(OCAMLOPT_EXISTS) # BYTE_ENABLED = $(not $(OCAMLOPT_EXISTS)) # # Various options # # OCAMLFLAGS += # OCAMLCFLAGS += # OCAMLOPTFLAGS += # OCAML_LINK_FLAGS += # OCAML_BYTE_LINK_FLAGS += # OCAML_NATIVE_LINK_FLAGS += ################################################ # Generated files # # Workaround for the fact that ocamldep does not pay attention to .mll # and .mly files. # # OCamlGeneratedFiles(parser.ml lexer.ml) ################################################ # Build an OCaml library # # FILES[] = # file1 # file2 # # LIB = main # # .DEFAULT: $(OCamlLibrary $(LIB), $(FILES)) ################################################ # Build an OCaml program # # FILES[] = # file1 # file2 # # PROGRAM = # OCAML_LIBS += # OCAML_CLIBS += # OCAML_OTHER_LIBS += # OCAML_LIB_FLAGS += # # .DEFAULT: $(OCamlProgram $(PROGRAM), $(FILES)) omake-0.10.3/lib/OMakeroot.default0000644000175000017500000000315613177364666015357 0ustar gerdgerd######################################################################## # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the # File is furnished to do so, subject to the following condition: # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, # DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR # OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE FILE OR # THE USE OR OTHER DEALINGS IN THE FILE. ######################################################################## # The standard OMakeroot file. # You will not normally need to modify this file. # By default, your changes should be placed in the # OMakefile in this directory. # # If you decide to modify this file, note that it uses exactly # the same syntax as the OMakefile. # # # Include the standard installed configuration files. # Any of these can be deleted if you are not using them, # but you probably want to keep the Common file. # open build/C open build/OCaml open build/LaTeX # # The command-line variables are defined *after* the # standard configuration has been loaded. # DefineCommandVars() # # Include the OMakefile in this directory. # .SUBDIRS: . omake-0.10.3/lib/OMakeroot.install0000644000175000017500000000263513177364666015402 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) ######################################################################## # General configuration. # # Copyright (C) 2003-2004 Jason Hickey and Mojave Group # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. # # By default, include all the preconfigured build projects. # open build/C open build/OCaml open build/LaTeX ######################################################################## # Define the command-line variables. # DefineCommandVars() omake-0.10.3/lib/OMakeroot.om0000644000175000017500000000253613177364666014347 0ustar gerdgerd######################################################################## # General configuration. # # Copyright (C) 2003-2004 Jason Hickey and Mojave Group # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. # # By default, include all the preconfigured build projects. # open build/C open build/OCaml open build/LaTeX ######################################################################## # Define the command-line variables. # DefineCommandVars() omake-0.10.3/lib/Pervasives.install0000644000175000017500000011225713177364666015633 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) ######################################################################## # Copyright (C) 2003-2007 Jason Hickey and Mojave Group # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. ######################################################################## # This file defines the Pervasives module--the standard module # open to every program. This is a bootstrap file. The syntax # here is mainly normal, but it is assumed that the basic classes # are empty at this point. You never need to assume this again. # class Pervasives ######################################################################## # Common variables and utilities # public. = declare BUILD_SUMMARY declare CWD declare FS declare GLOB_ALLOW declare GLOB_IGNORE declare GLOB_OPTIONS declare NF declare OMAKEPATH declare PATH declare RS declare STDLIB declare STDROOT declare TARGETS declare prompt declare EMPTY declare EMPTY_ARRAY const.EMPTY = const.EMPTY_ARRAY[] = const.TAB = $' ' const.false = false const.true = true shell-success(argv) = try value $(equal $(shell-code $(argv)), 0) default value $(not true) shell-success-null(argv) = # XXX: HACK: Is there a portable /dev/null? # Perhaps we should fix http://bugzilla.metaprl.org/show_bug.cgi?id=619 # and use a string out channel? tmp = $(tmpfile omake.shell-success-null) stdout = $(fopen $(tmp), w) stderr = $(stdout) res = $(shell-success $(argv)) close($(stdout)) rm(-f $(tmp)) return $(res) last(array) = return $(nth $(sub $(length $(array)), 1), $(array)) Bool(v) = value $(not $(not $v)) nonempty(l) = gt($(length $l), 0) # GNU Make - like join function join(l1, l2) = result[] = while $(and $(nonempty $(l1)), $(nonempty $(l2))) x = $(nth 0, $(l1)) y = $(nth 0, $(l2)) l1 = $(nth-tl 1, $(l1)) l2 = $(nth-tl 1, $(l2)) result[] += $x$y # From GNU Make docs: If one argument has more words that the other, # the extra words are copied unchanged into the result result[] += $(l1) result[] += $(l2) value $(result) # Documented in src/builtin/omake_builtin_sys.ml xterm-escape(s) = if $(xterm-escape-begin) value $(xterm-escape-begin)$s$(xterm-escape-end) else value $(EMPTY) prompt-invisible(s) = value $(prompt-invisible-begin)$s$(prompt-invisible-end) ######################################################################## # \begin{doc} # # \chapter{The standard objects} # \label{chapter:pervasives} # \cutname{omake-pervasives.html} # # \verb+Pervasives+ defines the objects that are defined in all # programs. The following objects are defined. # # \section{Pervasives objects} # # \obj{Object} # # Parent objects: none. # # The \verb+Object+ object is the root object. # Every class is a subclass of \verb+Object+. # # It provides the following fields: # # \begin{itemize} # \item \verb+$(o.object-length)+: the number of fields and methods in the object. # \item \verb+$(o.object-mem )+: returns \verb+true+ iff the \verb++ is a field # or method of the object. # \item \verb+$(o.object-add , )+: adds the field to the object, # returning a new object. # \item \verb+$(o.object-find )+: fetches the field or method from the object; # it is equivalent to \verb+$(o.)+, but the variable can be non-constant. # \item \verb+$(o.object-map )+: maps a function over the object. The function # should take two arguments; the first is a field name, the second is the # value of that field. The result is a new object constructed from the # values returned by the function. # \item \verb+o.object-foreach+: the \verb+object-foreach+ form is equivalent to \verb+object-map+, # but with altered syntax. # # \begin{verbatim} # o.object-foreach(, ) => # # \end{verbatim} # # For example, the following function prints all the fields of an # object \verb+o+. # # \begin{verbatim} # PrintObject(o) = # o.object-foreach(v, x) => # println($(v) = $(x)) # \end{verbatim} # # The \verb+export+ form is valid in a \verb+object-foreach+ body. The following # function collects just the field names of an object. # # \begin{verbatim} # FieldNames(o) = # names[] = # o.object-foreach(v, x) => # names[] += $(v) # export # return $(names) # \end{verbatim} # \end{itemize} # # \end{doc} # Object. += class Object object-length() = return $(obj-length $(this)) object-mem(v) = return $(obj-mem $(this), $(v)) object-add(v, x) = return $(obj-add $(this), $(v), $(x)) object-find(v) = return $(obj-find $(this), $(v)) object-map(f) = return $(obj-map $(this), $(f)) curry.object-foreach() = private.THIS = $(this) g(f) = export obj-map($(THIS), $(f)) instanceof(v) = return $(obj-instanceof $(this), $(v)) public.Object = $(this.Object) # # The runtime doesn't know to include the Object module, so do it now. # extends $(Object) # # \begin{doc} # \obj{Map} # # Parent objects: \verb+Object+. # # A \verb+Map+ object is a dictionary from values to values. The \verb++ # values are restricted to simple values: integers, floating-point numbers, # strings, files, directories, and arrays of simple values. # # The Map object provides the following methods. # # \begin{itemize} # \item \verb+$(o.length)+: the number of items in the map. # \item \verb+$(o.mem )+: returns \verb+true+ iff the \verb++ is defined # in the map. # \item \verb+$(o.add , )+: adds the field to the map, # returning a new map. # \item \verb+$(o.find )+: fetches the field from the map. # \item \verb+$(o.keys)+: fetches an array of all the keys in the map, in alphabetical order. # \item \verb+$(o.values)+: fetches an array of all the values in the map, # in the alphabetical order of the corresponding keys. # \item \verb+$(o.map )+: maps a function over the map. The function # should take two arguments; the first is a field name, the second is the # value of that field. The result is a new object constructed from the # values returned by the function. # \item \verb+o.foreach+: the \verb+foreach+ form is equivalent to \verb+map+, # but with altered syntax. # # \begin{verbatim} # o.foreach(, ) => # # \end{verbatim} # # For example, the following function prints all the fields of a # map \verb+o+. # # \begin{verbatim} # PrintMap(o) = # o.foreach(v, x) => # println($(v) = $(x)) # \end{verbatim} # # The \verb+export+ form is valid in a \verb+foreach+ body. The following # function reimplements the \verb+key+ method. # # \begin{verbatim} # FieldNames(o) = # names = # o.foreach(v, x) => # names += $(v) # export # return $(names) # \end{verbatim} # \end{itemize} # # There is also simpler syntax when the key is a string. The table can be # defined using definitions with the form \verb+$|key|+ # (the number of pipe symbols \verb+|+ is allowed to vary). # # \begin{verbatim} # $|key 1| = value1 # $||key1|key2|| = value2 # The key is key1|key2 # X = $|key 1| # Define X to be the value of field $|key 1| # \end{verbatim} # # The usual modifiers are also allowed. The expression \verb+$`|key|+ represents # lazy evaluation of the key, and \verb+$,|key|+ is normal evaluation. # # \end{doc} # Map. += class Map extends $(Object) mem(v) = return $(map-mem $(this), $(v)) add(v, x) = return $(map-add $(this), $(v), $(x)) remove(v) = return $(map-remove $(this), $(v)) find(v) = return $(map-find $(this), $(v)) map(f) = export return $(map-map $(this), $(f)) curry.foreach() = private.THIS = $(this) g(f) = export map-map($(THIS), $f) length() = return $(map-length $(this)) keys() = return $(map-keys $(this)) values() = return $(map-values $(this)) ######################################################################## # \begin{doc} # \obj{Number} # # Parent objects: \verb+Object+. # # The \verb+Number+ object is the parent object for integers # and floating-point numbers. # \end{doc} # Number. += class Number extends $(Object) public.Number = $(Number) # # \begin{doc} # \obj{Int} # # Parent objects: \verb+Number+. # # The \verb+Int+ object represents integer values. # \end{doc} # Int. += class Int extends $(Number) # # \begin{doc} # \obj{Float} # # Parent objects: \verb+Number+. # # The \verb+Float+ object represents floating-point numbers. # \end{doc} # Float. += class Float extends $(Number) ######################################################################## # \begin{doc} # \obj{Sequence} # # Parent objects: \verb+Object+. # # The \verb+Sequence+ object represents a generic object containing # sequential elements. It provides the following methods. # # \begin{itemize} # \item \verb+$(s.length)+: the number of elements in the sequence. # \item \verb+$(s.is-nonempty)+: true iff the expression \verb+$(s.nth 0)+ # will complete without failure. # \item \verb+$(s.nth )+: return the n'th element of the sequence. # \item \verb+$(s.nth-tl )+: return the n'th tail of the sequence. # \item \verb+$(s.map )+: maps a function over the fields in the sequence. # The function should take one argument. The result is a new sequence # constructed from the values returned by the function. # \item \verb+s.foreach+: the \verb+foreach+ form is equivalent to \verb+map+, # but with altered syntax. # # \begin{verbatim} # s.foreach() => # # \end{verbatim} # # For example, the following function prints all the elements of the sequence. # # \begin{verbatim} # PrintSequence(s) = # s.foreach(x) => # println(Elem = $(x)) # \end{verbatim} # # The \verb+export+ form is valid in a \verb+foreach+ body. The following # function counts the number of zeros in the sequence. # # \begin{verbatim} # Zeros(s) = # count = $(int 0) # s.foreach(v) => # if $(equal $(v), 0) # count = $(add $(count), 1) # export # export # return $(count) # \end{verbatim} # # \item \verb+$(s.forall )+: tests whether each element of the sequence # satifies a predicate. # \item \verb+$(s.exists )+: tests whether the sequence contains an element # that satisfies a predicate. # \item \verb+$(s.sort )+: sorts a sequence. The \verb++ is a comparison # function. It takes two elements \verb+(x, y)+ of the sequence, compares them, and returns # a negative number if $x < y$, a positive number if $x > y$, and zero if the two elements # are equal. # # \begin{verbatim} # osh> items = $(int 0 3 -2) # osh> items.forall(x => $(gt $x, 0)) # - : bool = false # osh> items.exists(x => $(gt $x, 0)) # - : bool = true # osh> items.sort($(compare)) # - : Array = -2 3 0 # \end{verbatim} # # \end{itemize} # \end{doc} # Sequence. += class Sequence extends $(Object) length() = sequence-length($(this)) is-nonempty() = sequence-nonempty($(this)) nth(i) = sequence-nth($(this), $(i)) nth-tl(i) = sequence-nth-tl($(this), $(i)) sub(off, len) = sequence-sub($(this), $(off), $(len)) rev() = sequence-rev($(this)) map(f) = sequence-map($(f), $(this)) # Note: private exports have no effect curry.foreach() = private.THIS = $(this) g(f) = export sequence-map($(f), $(THIS)) forall(f) = sequence-forall($f, $(this)) exists(f) = sequence-exists($f, $(this)) sort(f) = sequence-sort($f, $(this)) public.Sequence = $(Sequence) # # \begin{doc} # \obj{Array} # # Parent objects: \verb+Sequence+. # # The \verb+Array+ is a random-access sequence. # It provides the following additional methods. # # \begin{itemize} # \item \verb+$(s.nth )+: returns element \verb+i+ of the sequence. # \item \verb+$(s.rev )+: returns the reversed sequence. # \end{itemize} # # \end{doc} # Array. += class Array extends $(Sequence) public.Array = $(Array) # # \begin{doc} # \obj{String} # # Parent objects: \verb+Array+. # \end{doc} # String. += class String extends $(Array) ######################################################################## # \begin{doc} # \obj{Fun} # # Parent objects: \verb+Object+. # # The \verb+Fun+ object provides the following methods. # \begin{itemize} # \item \verb+$(f.arity)+: the arity if the function. # \end{itemize} # \end{doc} # Fun. += class Fun extends $(Object) arity() = return $(sequence-length $(this)) ######################################################################## # \begin{doc} # \obj{Rule} # # Parent objects: \verb+Object+. # # The \verb+Rule+ object represents a build rule. # It does not currently have any methods. # \end{doc} # Rule. += class Rule extends $(Object) # # \begin{doc} # \obj{Target} # # Parent object: \verb+Object+. # # The \verb+Target+ object contains information collected for # a specific target file. # # \begin{itemize} # \item \verb+target+: the target file. # \item \verb+effects+: the files that may be modified by a # side-effect when this target is built. # \item \verb+scanner_deps+: static dependencies that must be built # before this target can be scanned. # \item \verb+static-deps+: statically-defined build dependencies # of this target. # \item \verb+build-deps+: all the build dependencies for the target, # including static and scanned dependencies. # \item \verb+build-values+: all the value dependencies associated # with the build. # \item \verb+build-commands+: the commands to build the target. # \item \verb+output-file+: if output was diverted to a file, # with one of the \verb+--output-*+ options~\ref{chapter:options}, # this field names that file. Otherwise it is \verb+false+. # \end{itemize} # # The object supports the following methods. # # \begin{itemize} # \item \verb+find(file)+: returns a Target object for the given file. # Raises a \verb+RuntimeException+ if the specified target is # not part of the project. # \item \verb+find-optional(file)+: returns a \verb+Target+ object # for the given file, or \verb+false+ if the file is not # part of the project. # \end{itemize} # # NOTE: the information for a target is constructed dynamically, # so it is possible that the \verb+Target+ object for a node will # contain different values in different contexts. The easiest way # to make sure that the \verb+Target+ information is complete is # to compute it within a rule body, where the rule depends on # the target file, or the dependencies of the target file. # \end{doc} # Target. += class Target extends $(Object) target = effects = scanner-deps = static-deps = build-deps = build-values = build-commands = output-file = false find(file) = return $(target $(file)) find-optional(file) = return $(target-optional $(file)) ######################################################################## # \begin{doc} # \obj{Node} # # Parent objects: \verb+Object+. # # The \verb+Node+ object is the parent object for files and directories. # It supports the following operations. # \begin{itemize} # \end{doc} # Node. += class Node extends $(Object) # # \begin{doc} # \item \verb+$(node.stat)+: returns a \verb+stat+ object for the file. If the # file is a symbolic link, the \verb+stat+ information is for the destination of # the link, not the link itself. # # # \item \verb+$(node.lstat)+: returns a \verb+stat+ object for the file or symbolic link. # \end{doc} # stat() = return $(public.stat $(this)) lstat() = return $(public.lstat $(this)) # # \begin{doc} # \item \verb+$(node.unlink)+: removes the file. # \item \verb+$(node.rename )+: renames the file. # \item \verb+$(node.link )+: creates a hard link \verb++ to this file. # \item \verb+$(node.symlink )+: create a symbolic link \verb++ to this file. # \end{doc} # unlink() = return $(public.unlink $(this)) rename(file) = return $(public.rename $(this), $(file)) link(file) = return $(public.link $(this), $(file)) symlink(file) = return $(public.symlink $(this), $(file)) # # \begin{doc} # \item \verb+$(node.chmod )+: change the permission of this file. # \item \verb+$(node.chown , )+: change the owner and group id of this file. # \end{doc} # chmod(perm) = return $(public.chmod $(this), $(perm)) chown(uid, gid) = return $(public.chown $(this), $(uid), $(gid)) public.Node = $(Node) # # \begin{doc} # \end{itemize} # \end{doc} # # # \begin{doc} # \obj{File} # # Parent objects: \verb+Node+. # # The file object represents the name of a file. # \end{doc} # File. += class File extends $(Node) # # \begin{doc} # \obj{Dir} # # Parent objects: \verb+Node+. # # The \verb+Dir+ object represents the name of a directory. # \end{doc} # Dir. += class Dir extends $(Node) ######################################################################## # \begin{doc} # \obj{Channel} # # Parent objects: \verb+Object+. # # A \verb+Channel+ is a generic IO channel. # It provides the following methods. # \begin{itemize} # \end{doc} Channel. += class Channel extends $(Object) # # \begin{doc} # \item \verb+$(o.close)+: close the channel. # \end{doc} # close() = public.close($(this)) # # \begin{doc} # \item \verb+$(o.name)+: returns the file name associated with the channel. # \end{doc} # name() = return $(public.channel-name $(this)) public.Channel = $(this.Channel) # # \begin{doc} # \end{itemize} # \end{doc} # ######################################################################## # \begin{doc} # \obj{InChannel} # # Parent objects: \verb+Channel+. # # A \verb+InChannel+ is an input channel. The variable \verb+stdin+ is the # standard input channel. # # It provides the following methods. # \begin{itemize} # \end{doc} # InChannel. += class InChannel extends $(Channel) # # \begin{doc} # \item \verb+$(InChannel.fopen )+: open a new input channel. # \end{doc} # fopen(file) = return $(public.fopen $(file), r) # # \begin{doc} # \item \verb+$(InChannel.of-string )+: open a new input channel, # using a string as input. # \end{doc} of-string = $(open-in-string) # # \begin{doc} # \item \verb+$(o.read )+: reads the given number of characters from the channel # \end{doc} read(amount) = return $(public.read $(this), $(amount)) # # \begin{doc} # \item \verb+$(o.readln)+: reads a line from the channel # \end{doc} readln() = return $(public.input-line $(this)) # # \begin{doc} # \end{itemize} # \end{doc} # ######################################################################## # \begin{doc} # \obj{OutChannel} # # Parent object: \verb+Channel+. # # A \verb+OutChannel+ is an output channel. The variables \verb+stdout+ # and \verb+stderr+ are the standard output and error channels. # # It provides the following methods. # \begin{itemize} # \end{doc} # OutChannel. += class OutChannel extends $(Channel) # # \begin{doc} # \item \verb+$(OutChannel.fopen )+: open a new output channel. # \end{doc} # fopen(file) = return $(public.fopen $(file), w) # # \begin{doc} # \item \verb+$(OutChannel.string)+: open a new output channel, # writing to a string. # \end{doc} # to-string() = return $(public.open-out-string) # # \begin{doc} # \item \verb+$(OutChannel.to-string)+: get the current string of # output, for an output channel created as \verb+OutChannel.open-string+. # \end{doc} # contents() = return $(public.out-contents $(this)) # # \begin{doc} # \item \verb+$(OutChannel.append )+: opens a new output channel, # appending to the file. # \end{doc} # append(file) = return $(public.fopen $(file), a) # # \begin{doc} # \item \verb+$(c.flush)+: flush the output channel. # \end{doc} # flush() = return $(public.flush $(this)) # # \begin{doc} # \item \verb+$(c.print )+: print a string to the channel. # \end{doc} # print(s) = return $(public.fprint $(this), $(s)) # # \begin{doc} # \item \verb+$(c.println )+: print a string to the channel, # followed by a line terminator. # \end{doc} # println(s) = return $(public.fprintln $(this), $(s)) # # \begin{doc} # \end{itemize} # \end{doc} # ######################################################################## # \begin{doc} # \obj{Location} # # Parent objects: \verb+Location+. # # The \verb+Location+ object represents a location in a file. # \end{doc} # Location. += class Location extends $(Object) to-string() = string-of-location($(this)) ######################################################################## # \begin{doc} # \obj{Exception} # # Parent objects: \verb+Object+. # # The \verb+Exception+ object is used as the base object for exceptions. # It has no fields. # \end{doc} # Exception. += class Exception extends $(Object) public.Exception = $(Exception) # # \begin{doc} # \obj{RuntimeException} # # Parent objects: \verb+Exception+. # # The \verb+RuntimeException+ object represents an exception from the # runtime system. It has the following fields. # # \begin{itemize} # \item \verb+position+: a string representing the location where the # exception was raised. # \item \verb+message+: a string containing the exception message. # \end{itemize} # \end{doc} # RuntimeException. += class RuntimeException extends $(Exception) position = no position message = no message # # \begin{doc} # \obj{UnbuildableException} # # Parent objects: \verb+Exception+. # # The \verb+UnbuildableException+ object should be used to signal that a target # is not buildable. It will be caught by functions such as # \hyperfunn{target-exists}. # This exception has the following fields: # # \begin{itemize} # \item \verb+target+: indicates which target is not buildable. # \item \verb+message+: a string containing the exception message. # \end{itemize} # \end{doc} # UnbuildableException. += class UnbuildableException extends $(Exception) message = no message target = no target ######################################################################## # System objects. # Select. += class Select extends $(Object) Pipe. += class Pipe extends $(Object) Stat. += class Stat extends $(Object) Passwd. += class Passwd extends $(Object) Group. += class Group extends $(Object) Tm. += class Tm extends $(Object) tm_sec = $(int 0) tm_min = $(int 0) tm_hour = $(int 0) tm_mday = $(int 0) tm_mon = $(int 0) tm_year = $(int 0) tm_wday = $(int 0) tm_yday = $(int 0) tm_isdst = false ######################################################################## # The shell object. # # \begin{doc} # \obj{Shell} # # Parent objects: \verb+Object+. # # The \verb+Shell+ object contains the collection of builtin functions # available as shell commands. # # You can define aliases by extending this object with additional methods. # All methods in this class are called with one argument: a single array # containing an argument list. # # \begin{itemize} # \end{doc} # Shell. += class Shell extends $(Object) # # \begin{doc} # \itemidx{echo} # # The \verb+echo+ function prints its arguments to the standard output channel. # \end{doc} # echo = $(echo) # # \begin{doc} # \itemidx{jobs} # # The \verb+jobs+ method prints the status of currently running commands. # \end{doc} # jobs = $(jobs) getpwnam = $(getpwnam) getpwuid = $(getpwuid) getgrnam = $(getgrnam) getgrgid = $(getgrgid) # # \begin{doc} # \itemidx{cd} # # The \verb+cd+ function changes the current directory. # Note that the current directory follows the usual scoping # rules. For example, the following program lists the # files in the \verb+foo+ directory, but the current # directory is not changed. # # \begin{verbatim} # section # echo Listing files in the foo directory... # cd foo # ls # # echo Listing files in the current directory... # ls # \end{verbatim} # \end{doc} # cd = $(cd) # # \begin{doc} # \itemidx{bg} # # The \verb+bg+ method places a job in the background. # The job is resumed if it has been suspended. # \end{doc} # bg = $(bg) # # \begin{doc} # \itemidx{fg} # # The \verb+fg+ method brings a job to the foreground. # The job is resumed if it has been suspended. # \end{doc} # fg = $(fg) # # \begin{doc} # \itemidx{stop} # # The \verb+stop+ method suspends a running job. # \end{doc} # stop = $(stop) # # \begin{doc} # \itemidx{wait} # # The \verb+wait+ function waits for a running job to terminate. # It is not possible to wait for a suspended job. # # The job is not brought to the foreground. If the \verb+wait+ # is interrupted, the job continues to run in the background. # \end{doc} # wait = $(wait) # # \begin{doc} # \itemidx{kill} # # The \verb+kill+ function signal a job. # # \verb+kill [signal] +. # # The signals are either numeric, or symbolic. # The symbolic signals are named as follows. # # ABRT, ALRM, HUP, ILL, KILL, QUIT, SEGV, TERM, USR1, # USR2, CHLD, STOP, TSTP, TTIN, TTOU, VTALRM, PROF. # \end{doc} # kill = $(kill) # # \begin{doc} # \itemidx{exit} # # The \verb+exit+ function terminates the current session. # \end{doc} # exit = $(exit-parent) # # \begin{doc} # \itemtwoidx{which}{where} # # See the documentation for the corresponding functions. # \end{doc} which(argv) = println($(which $(argv))) where(argv) = res[] = $(where $(argv)) res.map($(println)) return $(int 0) # # \begin{doc} # \itemidx{rehash} # # Reset the search path. # \end{doc} # rehash(argv) = rehash() # # \begin{doc} # \itemidx{ln-or-cp} \em{src} \em{dst} # # Links or copies \em{src} to \em{dst}, overwriting \em{dst}. Namely, \verb+ln-or-cp+ would first # delete the \em{dst} file (unless it is a directory), if it exists. Next it would try to create # a symbolic link \em{dst} poiting to \em{src} (it will make all the necessary adjustmnents of # relative paths). If symbolic link can not be created (\emph{e.g.} the OS or the filesystem does # not support symbolic links), it will try to create a hard link. If that fails too, it will try # to forcibly copy \em{src} to \em{dst}. # \end{doc} # ln-or-cp(argv) = if $(not $(eq $(length $(argv)), 2)) eprintln($"Shell.ln-or-cp: expected 2 arguments, received $(length $(argv)) arguments") exit(1) src = $(file $"$(nth 0, $(argv))") dst = $(file $"$(nth 1, $(argv))") if $(and $(test -e $(dst)), $(not $(test -d $(dst)))) rm($(array -f, $(dst))) if $(test -e $(dst)) # The dst might be read-only; on Windows this will prevent deletion. # Will try to fix the permissions and rm again. # If dst and src are already hardliked, this will break # the permissions on src, so we will try to restore them. src_was_ro = $(not $(test -w $(src))) chmod -f -m u+w $(dst) rm($(array -f, $(dst))) if $(and $(src_was_ro), $(test -w $(src))) chmod -f -m u-w $(src) try symlink($(src), $(dst)) default try link($(src), $(dst)) default if $(and $(test -e $(dst)), $(not $(test -d $(dst)))) # NB: $(dst) might already be a hardlink and we failed to delete it # Trying to cp in that case might cause both $(src) and $(dst) to # get truncated! eprintln($"ln-or-cp: failed to remove the destination file $(dst) before overwriting; giving up.") exit(1) return $(cp $(array -f, $(src), $(dst))) # # \begin{doc} # \itemidx{history} # # Print the current command-line history. # \end{doc} # history(argv) = lines = $(public.history) lines.map($(println)) return $(int 0) # # \begin{doc} # \itemidx{digest} # # Print the digests of the given files. # \end{doc} # digest(argv) = foreach(n => ..., $(argv)) println($"$n: $(digest $n)") value # # \begin{doc} # \item Win32 functions. # # Win32 doesn't provide very many programs for scripting, except # for the functions that are builtin to the DOS \verb+cmd.exe+. # The following functions are defined on Win32 and only on Win32. # On other systems, it is expected that these programs already # exist. # # \begin{itemize} # \end{doc} # if $(equal $(OSTYPE), Win32) # # \begin{doc} # \itemidx{grep} # # \begin{verbatim} # grep [-q] [-n] [-v] [-h] pattern files... # \end{verbatim} # # The \verb+grep+ alias calls the \Prog{omake}'s internal \hyperfun{grep}. # \end{doc} # grep = $(builtin-grep) export # # \begin{doc} # \end{itemize} # \end{doc} # # # \begin{doc} Internal versions of standard system commands. # # By default, \Prog{omake} uses internal versions of the following commands: # \verb+cp+, \verb+mv+, \verb+cat+, \verb+rm+, \verb+mkdir+, \verb+chmod+, # \verb+test+, \verb+find+. # If you really want to use the standard system versions of these # commands, set the \verb+USE_SYSTEM_COMMANDS+ as one of the first # definitions in your \verb+OMakeroot+ file. # # \begin{itemize} # \end{doc} # declare [ declare true if $(not $(defined USE_SYSTEM_COMMANDS)) # # \begin{doc} # \itemidx{pwd} # # \begin{verbatim} # pwd # \end{verbatim} # # The \verb+pwd+ alias would print the absolute path to current directory. # \end{doc} # pwd(argv) = println($(absname .)) # # \begin{doc} # \itemidx{mkdir} # # \begin{verbatim} # mkdir [-m ] [-p] files # \end{verbatim} # # The \verb+mkdir+ function is used to create directories. # The -verb+-m+ option can be used to specify the permission # mode of the created directory. If the \verb+-p+ option # is specified, the full path is created. # \end{doc} # mkdir = $(mkdir) # # \begin{doc} # \itemtwoidx{cp}{mv} # # \begin{verbatim} # cp [-f] [-i] [-v] src dst # cp [-f] [-i] [-v] files dst # mv [-f] [-i] [-v] src dst # mv [-f] [-i] [-v] files dst # \end{verbatim} # # The \verb+cp+ function copies a \verb+src+ file to # a \verb+dst+ file, overwriting it if it already exists. # If more than one source file is specified, the final file # must be a directory, and the source files are copied # into the directory. # # \begin{description} # \item[-f] Copy files forcibly, do not prompt. # \item[-i] Prompt before removing destination files. # \item[-v] Explain what is happening. # \end{description} # \end{doc} # cp = $(cp) mv = $(mv) # # \begin{doc} # \itemidx{rm} # # \begin{verbatim} # rm [-f] [-i] [-v] [-r] files # rmdir [-f] [-i] [-v] [-r] dirs # \end{verbatim} # # The \verb+rm+ function removes a set of files. # No warnings are issued if the files do not exist, or if # they cannot be removed. # # Options: # \begin{description} # \item[-f] Forcibly remove files, do not prompt. # \item[-i] Prompt before removal. # \item[-v] Explain what is happening. # \item[-r] Remove contents of directories recursively. # \end{description} # \end{doc} # rm = $(rm) rmdir = $(rmdir) # # \begin{doc} # \itemidx{chmod} # # \begin{verbatim} # chmod [-r] [-v] [-f] mode files # \end{verbatim} # # The \verb+chmod+ function changes the permissions on a set of # files or directories. This function does nothing on Win32. # The \verb+mode+ may be specified as an octal number, # or in symbolic form \verb+[ugoa]*[+-=][rwxXstugo]+. # See the man page for \verb+chmod+ for details. # # Options: # \begin{description} # \item[-r] Change permissions of all files in a directory recursively. # \item[-v] Explain what is happening. # \item[-f] Continue on errors. # \end{description} # \end{doc} # chmod = $(chmod) # # \begin{doc} # \itemidx{cat} # # \begin{verbatim} # cat files... # \end{verbatim} # # The \verb+cat+ function prints the contents of the files to stdout # \end{doc} # cat(argv)= print($(cat $(argv))) # # \begin{doc} # \itemidx{test} # # \verb+test+ \emph{expression}\\ # \verb+[+ \emph{expression} +]+\\ # \verb+[ --help+\\ # \verb+[ --version+\\ # # See the documentation for the \hyperfun{test}. # # \end{doc} # test = $(builtin-test) [ = $(builtin-test-brack) # # \begin{doc} # \itemidx{find} # # \verb+find+ \emph{expression} # # See the documentation for the \hyperfun{find}. # # \end{doc} # find = $(builtin-find) true(argv) = return true export # # \begin{doc} # \end{itemize} # \end{doc} # # # \begin{doc} # \end{itemize} # \end{doc} # # # These are all documented in Omake_builtin_io_fun. # declare parse-loc Token. = class Token loc = name = val = unit(name) = this.loc = $(parse-loc) this.name = $(name) return $(this) pair(name, val) = this.loc = $(parse-loc) this.name = $(name) this.val = $(val) return $(this) rename(name) = this.name = $(name) return $(this) Lexer. += class Lexer extends $(Object) declare channel # # For interpreting the rules # rule = $(lex-rule) # # To use a lexer, you would normally hand it a channel # from-channel(channel) = this.channel = $(channel) return $(this) lex() = return $(lex-engine $(this.channel)) lex-channel(channel) = this.channel = $(channel) return $(lex-engine $(channel)) set-line(filename, line) = set-channel-line($(channel), $(filename), $(line)) Parser. += class Parser extends $(Object) # # For interpreting the rules # rule = $(parse-rule) # # You must set the lexer # lexer = # # Start symbols # start = $(parse-start) # # Precedence operations # left = $(parse-left) right = $(parse-right) nonassoc = $(parse-nonassoc) # # Manipulating the current precedence level # prec-min = $".min" prec-max = $".max" current-prec = $".min" # # Build the parser # build = $(parse-build) # # Main parsing function # parse(sym) = return $(parse-engine $(sym)) parse-channel(sym, channel) = lexer = $(lexer.from-channel $(channel)) return $(parse-engine $(sym)) parse-file(sym, file) = channel = $(fopen $(file), r) lexer = $(lexer.from-channel $(channel)) result = $(parse-engine $(sym)) close($(channel)) return $(result) omake-0.10.3/lib/Pervasives.om0000644000175000017500000011216013177364666014571 0ustar gerdgerd######################################################################## # Copyright (C) 2003-2007 Jason Hickey and Mojave Group # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. ######################################################################## # This file defines the Pervasives module--the standard module # open to every program. This is a bootstrap file. The syntax # here is mainly normal, but it is assumed that the basic classes # are empty at this point. You never need to assume this again. # class Pervasives ######################################################################## # Common variables and utilities # public. = declare BUILD_SUMMARY declare CWD declare FS declare GLOB_ALLOW declare GLOB_IGNORE declare GLOB_OPTIONS declare NF declare OMAKEPATH declare PATH declare RS declare STDLIB declare STDROOT declare TARGETS declare prompt declare EMPTY declare EMPTY_ARRAY const.EMPTY = const.EMPTY_ARRAY[] = const.TAB = $' ' const.false = false const.true = true shell-success(argv) = try value $(equal $(shell-code $(argv)), 0) default value $(not true) shell-success-null(argv) = # XXX: HACK: Is there a portable /dev/null? # Perhaps we should fix http://bugzilla.metaprl.org/show_bug.cgi?id=619 # and use a string out channel? tmp = $(tmpfile omake.shell-success-null) stdout = $(fopen $(tmp), w) stderr = $(stdout) res = $(shell-success $(argv)) close($(stdout)) rm(-f $(tmp)) return $(res) last(array) = return $(nth $(sub $(length $(array)), 1), $(array)) Bool(v) = value $(not $(not $v)) nonempty(l) = gt($(length $l), 0) # GNU Make - like join function join(l1, l2) = result[] = while $(and $(nonempty $(l1)), $(nonempty $(l2))) x = $(nth 0, $(l1)) y = $(nth 0, $(l2)) l1 = $(nth-tl 1, $(l1)) l2 = $(nth-tl 1, $(l2)) result[] += $x$y # From GNU Make docs: If one argument has more words that the other, # the extra words are copied unchanged into the result result[] += $(l1) result[] += $(l2) value $(result) # Documented in src/builtin/omake_builtin_sys.ml xterm-escape(s) = if $(xterm-escape-begin) value $(xterm-escape-begin)$s$(xterm-escape-end) else value $(EMPTY) prompt-invisible(s) = value $(prompt-invisible-begin)$s$(prompt-invisible-end) ######################################################################## # \begin{doc} # # \chapter{The standard objects} # \label{chapter:pervasives} # \cutname{omake-pervasives.html} # # \verb+Pervasives+ defines the objects that are defined in all # programs. The following objects are defined. # # \section{Pervasives objects} # # \obj{Object} # # Parent objects: none. # # The \verb+Object+ object is the root object. # Every class is a subclass of \verb+Object+. # # It provides the following fields: # # \begin{itemize} # \item \verb+$(o.object-length)+: the number of fields and methods in the object. # \item \verb+$(o.object-mem )+: returns \verb+true+ iff the \verb++ is a field # or method of the object. # \item \verb+$(o.object-add , )+: adds the field to the object, # returning a new object. # \item \verb+$(o.object-find )+: fetches the field or method from the object; # it is equivalent to \verb+$(o.)+, but the variable can be non-constant. # \item \verb+$(o.object-map )+: maps a function over the object. The function # should take two arguments; the first is a field name, the second is the # value of that field. The result is a new object constructed from the # values returned by the function. # \item \verb+o.object-foreach+: the \verb+object-foreach+ form is equivalent to \verb+object-map+, # but with altered syntax. # # \begin{verbatim} # o.object-foreach(, ) => # # \end{verbatim} # # For example, the following function prints all the fields of an # object \verb+o+. # # \begin{verbatim} # PrintObject(o) = # o.object-foreach(v, x) => # println($(v) = $(x)) # \end{verbatim} # # The \verb+export+ form is valid in a \verb+object-foreach+ body. The following # function collects just the field names of an object. # # \begin{verbatim} # FieldNames(o) = # names[] = # o.object-foreach(v, x) => # names[] += $(v) # export # return $(names) # \end{verbatim} # \end{itemize} # # \end{doc} # Object. += class Object object-length() = return $(obj-length $(this)) object-mem(v) = return $(obj-mem $(this), $(v)) object-add(v, x) = return $(obj-add $(this), $(v), $(x)) object-find(v) = return $(obj-find $(this), $(v)) object-map(f) = return $(obj-map $(this), $(f)) curry.object-foreach() = private.THIS = $(this) g(f) = export obj-map($(THIS), $(f)) instanceof(v) = return $(obj-instanceof $(this), $(v)) public.Object = $(this.Object) # # The runtime doesn't know to include the Object module, so do it now. # extends $(Object) # # \begin{doc} # \obj{Map} # # Parent objects: \verb+Object+. # # A \verb+Map+ object is a dictionary from values to values. The \verb++ # values are restricted to simple values: integers, floating-point numbers, # strings, files, directories, and arrays of simple values. # # The Map object provides the following methods. # # \begin{itemize} # \item \verb+$(o.length)+: the number of items in the map. # \item \verb+$(o.mem )+: returns \verb+true+ iff the \verb++ is defined # in the map. # \item \verb+$(o.add , )+: adds the field to the map, # returning a new map. # \item \verb+$(o.find )+: fetches the field from the map. # \item \verb+$(o.keys)+: fetches an array of all the keys in the map, in alphabetical order. # \item \verb+$(o.values)+: fetches an array of all the values in the map, # in the alphabetical order of the corresponding keys. # \item \verb+$(o.map )+: maps a function over the map. The function # should take two arguments; the first is a field name, the second is the # value of that field. The result is a new object constructed from the # values returned by the function. # \item \verb+o.foreach+: the \verb+foreach+ form is equivalent to \verb+map+, # but with altered syntax. # # \begin{verbatim} # o.foreach(, ) => # # \end{verbatim} # # For example, the following function prints all the fields of a # map \verb+o+. # # \begin{verbatim} # PrintMap(o) = # o.foreach(v, x) => # println($(v) = $(x)) # \end{verbatim} # # The \verb+export+ form is valid in a \verb+foreach+ body. The following # function reimplements the \verb+key+ method. # # \begin{verbatim} # FieldNames(o) = # names = # o.foreach(v, x) => # names += $(v) # export # return $(names) # \end{verbatim} # \end{itemize} # # There is also simpler syntax when the key is a string. The table can be # defined using definitions with the form \verb+$|key|+ # (the number of pipe symbols \verb+|+ is allowed to vary). # # \begin{verbatim} # $|key 1| = value1 # $||key1|key2|| = value2 # The key is key1|key2 # X = $|key 1| # Define X to be the value of field $|key 1| # \end{verbatim} # # The usual modifiers are also allowed. The expression \verb+$`|key|+ represents # lazy evaluation of the key, and \verb+$,|key|+ is normal evaluation. # # \end{doc} # Map. += class Map extends $(Object) mem(v) = return $(map-mem $(this), $(v)) add(v, x) = return $(map-add $(this), $(v), $(x)) remove(v) = return $(map-remove $(this), $(v)) find(v) = return $(map-find $(this), $(v)) map(f) = export return $(map-map $(this), $(f)) curry.foreach() = private.THIS = $(this) g(f) = export map-map($(THIS), $f) length() = return $(map-length $(this)) keys() = return $(map-keys $(this)) values() = return $(map-values $(this)) ######################################################################## # \begin{doc} # \obj{Number} # # Parent objects: \verb+Object+. # # The \verb+Number+ object is the parent object for integers # and floating-point numbers. # \end{doc} # Number. += class Number extends $(Object) public.Number = $(Number) # # \begin{doc} # \obj{Int} # # Parent objects: \verb+Number+. # # The \verb+Int+ object represents integer values. # \end{doc} # Int. += class Int extends $(Number) # # \begin{doc} # \obj{Float} # # Parent objects: \verb+Number+. # # The \verb+Float+ object represents floating-point numbers. # \end{doc} # Float. += class Float extends $(Number) ######################################################################## # \begin{doc} # \obj{Sequence} # # Parent objects: \verb+Object+. # # The \verb+Sequence+ object represents a generic object containing # sequential elements. It provides the following methods. # # \begin{itemize} # \item \verb+$(s.length)+: the number of elements in the sequence. # \item \verb+$(s.is-nonempty)+: true iff the expression \verb+$(s.nth 0)+ # will complete without failure. # \item \verb+$(s.nth )+: return the n'th element of the sequence. # \item \verb+$(s.nth-tl )+: return the n'th tail of the sequence. # \item \verb+$(s.map )+: maps a function over the fields in the sequence. # The function should take one argument. The result is a new sequence # constructed from the values returned by the function. # \item \verb+s.foreach+: the \verb+foreach+ form is equivalent to \verb+map+, # but with altered syntax. # # \begin{verbatim} # s.foreach() => # # \end{verbatim} # # For example, the following function prints all the elements of the sequence. # # \begin{verbatim} # PrintSequence(s) = # s.foreach(x) => # println(Elem = $(x)) # \end{verbatim} # # The \verb+export+ form is valid in a \verb+foreach+ body. The following # function counts the number of zeros in the sequence. # # \begin{verbatim} # Zeros(s) = # count = $(int 0) # s.foreach(v) => # if $(equal $(v), 0) # count = $(add $(count), 1) # export # export # return $(count) # \end{verbatim} # # \item \verb+$(s.forall )+: tests whether each element of the sequence # satifies a predicate. # \item \verb+$(s.exists )+: tests whether the sequence contains an element # that satisfies a predicate. # \item \verb+$(s.sort )+: sorts a sequence. The \verb++ is a comparison # function. It takes two elements \verb+(x, y)+ of the sequence, compares them, and returns # a negative number if $x < y$, a positive number if $x > y$, and zero if the two elements # are equal. # # \begin{verbatim} # osh> items = $(int 0 3 -2) # osh> items.forall(x => $(gt $x, 0)) # - : bool = false # osh> items.exists(x => $(gt $x, 0)) # - : bool = true # osh> items.sort($(compare)) # - : Array = -2 3 0 # \end{verbatim} # # \end{itemize} # \end{doc} # Sequence. += class Sequence extends $(Object) length() = sequence-length($(this)) is-nonempty() = sequence-nonempty($(this)) nth(i) = sequence-nth($(this), $(i)) nth-tl(i) = sequence-nth-tl($(this), $(i)) sub(off, len) = sequence-sub($(this), $(off), $(len)) rev() = sequence-rev($(this)) map(f) = sequence-map($(f), $(this)) # Note: private exports have no effect curry.foreach() = private.THIS = $(this) g(f) = export sequence-map($(f), $(THIS)) forall(f) = sequence-forall($f, $(this)) exists(f) = sequence-exists($f, $(this)) sort(f) = sequence-sort($f, $(this)) public.Sequence = $(Sequence) # # \begin{doc} # \obj{Array} # # Parent objects: \verb+Sequence+. # # The \verb+Array+ is a random-access sequence. # It provides the following additional methods. # # \begin{itemize} # \item \verb+$(s.nth )+: returns element \verb+i+ of the sequence. # \item \verb+$(s.rev )+: returns the reversed sequence. # \end{itemize} # # \end{doc} # Array. += class Array extends $(Sequence) public.Array = $(Array) # # \begin{doc} # \obj{String} # # Parent objects: \verb+Array+. # \end{doc} # String. += class String extends $(Array) ######################################################################## # \begin{doc} # \obj{Fun} # # Parent objects: \verb+Object+. # # The \verb+Fun+ object provides the following methods. # \begin{itemize} # \item \verb+$(f.arity)+: the arity if the function. # \end{itemize} # \end{doc} # Fun. += class Fun extends $(Object) arity() = return $(sequence-length $(this)) ######################################################################## # \begin{doc} # \obj{Rule} # # Parent objects: \verb+Object+. # # The \verb+Rule+ object represents a build rule. # It does not currently have any methods. # \end{doc} # Rule. += class Rule extends $(Object) # # \begin{doc} # \obj{Target} # # Parent object: \verb+Object+. # # The \verb+Target+ object contains information collected for # a specific target file. # # \begin{itemize} # \item \verb+target+: the target file. # \item \verb+effects+: the files that may be modified by a # side-effect when this target is built. # \item \verb+scanner_deps+: static dependencies that must be built # before this target can be scanned. # \item \verb+static-deps+: statically-defined build dependencies # of this target. # \item \verb+build-deps+: all the build dependencies for the target, # including static and scanned dependencies. # \item \verb+build-values+: all the value dependencies associated # with the build. # \item \verb+build-commands+: the commands to build the target. # \item \verb+output-file+: if output was diverted to a file, # with one of the \verb+--output-*+ options~\ref{chapter:options}, # this field names that file. Otherwise it is \verb+false+. # \end{itemize} # # The object supports the following methods. # # \begin{itemize} # \item \verb+find(file)+: returns a Target object for the given file. # Raises a \verb+RuntimeException+ if the specified target is # not part of the project. # \item \verb+find-optional(file)+: returns a \verb+Target+ object # for the given file, or \verb+false+ if the file is not # part of the project. # \end{itemize} # # NOTE: the information for a target is constructed dynamically, # so it is possible that the \verb+Target+ object for a node will # contain different values in different contexts. The easiest way # to make sure that the \verb+Target+ information is complete is # to compute it within a rule body, where the rule depends on # the target file, or the dependencies of the target file. # \end{doc} # Target. += class Target extends $(Object) target = effects = scanner-deps = static-deps = build-deps = build-values = build-commands = output-file = false find(file) = return $(target $(file)) find-optional(file) = return $(target-optional $(file)) ######################################################################## # \begin{doc} # \obj{Node} # # Parent objects: \verb+Object+. # # The \verb+Node+ object is the parent object for files and directories. # It supports the following operations. # \begin{itemize} # \end{doc} # Node. += class Node extends $(Object) # # \begin{doc} # \item \verb+$(node.stat)+: returns a \verb+stat+ object for the file. If the # file is a symbolic link, the \verb+stat+ information is for the destination of # the link, not the link itself. # # # \item \verb+$(node.lstat)+: returns a \verb+stat+ object for the file or symbolic link. # \end{doc} # stat() = return $(public.stat $(this)) lstat() = return $(public.lstat $(this)) # # \begin{doc} # \item \verb+$(node.unlink)+: removes the file. # \item \verb+$(node.rename )+: renames the file. # \item \verb+$(node.link )+: creates a hard link \verb++ to this file. # \item \verb+$(node.symlink )+: create a symbolic link \verb++ to this file. # \end{doc} # unlink() = return $(public.unlink $(this)) rename(file) = return $(public.rename $(this), $(file)) link(file) = return $(public.link $(this), $(file)) symlink(file) = return $(public.symlink $(this), $(file)) # # \begin{doc} # \item \verb+$(node.chmod )+: change the permission of this file. # \item \verb+$(node.chown , )+: change the owner and group id of this file. # \end{doc} # chmod(perm) = return $(public.chmod $(this), $(perm)) chown(uid, gid) = return $(public.chown $(this), $(uid), $(gid)) public.Node = $(Node) # # \begin{doc} # \end{itemize} # \end{doc} # # # \begin{doc} # \obj{File} # # Parent objects: \verb+Node+. # # The file object represents the name of a file. # \end{doc} # File. += class File extends $(Node) # # \begin{doc} # \obj{Dir} # # Parent objects: \verb+Node+. # # The \verb+Dir+ object represents the name of a directory. # \end{doc} # Dir. += class Dir extends $(Node) ######################################################################## # \begin{doc} # \obj{Channel} # # Parent objects: \verb+Object+. # # A \verb+Channel+ is a generic IO channel. # It provides the following methods. # \begin{itemize} # \end{doc} Channel. += class Channel extends $(Object) # # \begin{doc} # \item \verb+$(o.close)+: close the channel. # \end{doc} # close() = public.close($(this)) # # \begin{doc} # \item \verb+$(o.name)+: returns the file name associated with the channel. # \end{doc} # name() = return $(public.channel-name $(this)) public.Channel = $(this.Channel) # # \begin{doc} # \end{itemize} # \end{doc} # ######################################################################## # \begin{doc} # \obj{InChannel} # # Parent objects: \verb+Channel+. # # A \verb+InChannel+ is an input channel. The variable \verb+stdin+ is the # standard input channel. # # It provides the following methods. # \begin{itemize} # \end{doc} # InChannel. += class InChannel extends $(Channel) # # \begin{doc} # \item \verb+$(InChannel.fopen )+: open a new input channel. # \end{doc} # fopen(file) = return $(public.fopen $(file), r) # # \begin{doc} # \item \verb+$(InChannel.of-string )+: open a new input channel, # using a string as input. # \end{doc} of-string = $(open-in-string) # # \begin{doc} # \item \verb+$(o.read )+: reads the given number of characters from the channel # \end{doc} read(amount) = return $(public.read $(this), $(amount)) # # \begin{doc} # \item \verb+$(o.readln)+: reads a line from the channel # \end{doc} readln() = return $(public.input-line $(this)) # # \begin{doc} # \end{itemize} # \end{doc} # ######################################################################## # \begin{doc} # \obj{OutChannel} # # Parent object: \verb+Channel+. # # A \verb+OutChannel+ is an output channel. The variables \verb+stdout+ # and \verb+stderr+ are the standard output and error channels. # # It provides the following methods. # \begin{itemize} # \end{doc} # OutChannel. += class OutChannel extends $(Channel) # # \begin{doc} # \item \verb+$(OutChannel.fopen )+: open a new output channel. # \end{doc} # fopen(file) = return $(public.fopen $(file), w) # # \begin{doc} # \item \verb+$(OutChannel.string)+: open a new output channel, # writing to a string. # \end{doc} # to-string() = return $(public.open-out-string) # # \begin{doc} # \item \verb+$(OutChannel.to-string)+: get the current string of # output, for an output channel created as \verb+OutChannel.open-string+. # \end{doc} # contents() = return $(public.out-contents $(this)) # # \begin{doc} # \item \verb+$(OutChannel.append )+: opens a new output channel, # appending to the file. # \end{doc} # append(file) = return $(public.fopen $(file), a) # # \begin{doc} # \item \verb+$(c.flush)+: flush the output channel. # \end{doc} # flush() = return $(public.flush $(this)) # # \begin{doc} # \item \verb+$(c.print )+: print a string to the channel. # \end{doc} # print(s) = return $(public.fprint $(this), $(s)) # # \begin{doc} # \item \verb+$(c.println )+: print a string to the channel, # followed by a line terminator. # \end{doc} # println(s) = return $(public.fprintln $(this), $(s)) # # \begin{doc} # \end{itemize} # \end{doc} # ######################################################################## # \begin{doc} # \obj{Location} # # Parent objects: \verb+Location+. # # The \verb+Location+ object represents a location in a file. # \end{doc} # Location. += class Location extends $(Object) to-string() = string-of-location($(this)) ######################################################################## # \begin{doc} # \obj{Exception} # # Parent objects: \verb+Object+. # # The \verb+Exception+ object is used as the base object for exceptions. # It has no fields. # \end{doc} # Exception. += class Exception extends $(Object) public.Exception = $(Exception) # # \begin{doc} # \obj{RuntimeException} # # Parent objects: \verb+Exception+. # # The \verb+RuntimeException+ object represents an exception from the # runtime system. It has the following fields. # # \begin{itemize} # \item \verb+position+: a string representing the location where the # exception was raised. # \item \verb+message+: a string containing the exception message. # \end{itemize} # \end{doc} # RuntimeException. += class RuntimeException extends $(Exception) position = no position message = no message # # \begin{doc} # \obj{UnbuildableException} # # Parent objects: \verb+Exception+. # # The \verb+UnbuildableException+ object should be used to signal that a target # is not buildable. It will be caught by functions such as # \hyperfunn{target-exists}. # This exception has the following fields: # # \begin{itemize} # \item \verb+target+: indicates which target is not buildable. # \item \verb+message+: a string containing the exception message. # \end{itemize} # \end{doc} # UnbuildableException. += class UnbuildableException extends $(Exception) message = no message target = no target ######################################################################## # System objects. # Select. += class Select extends $(Object) Pipe. += class Pipe extends $(Object) Stat. += class Stat extends $(Object) Passwd. += class Passwd extends $(Object) Group. += class Group extends $(Object) Tm. += class Tm extends $(Object) tm_sec = $(int 0) tm_min = $(int 0) tm_hour = $(int 0) tm_mday = $(int 0) tm_mon = $(int 0) tm_year = $(int 0) tm_wday = $(int 0) tm_yday = $(int 0) tm_isdst = false ######################################################################## # The shell object. # # \begin{doc} # \obj{Shell} # # Parent objects: \verb+Object+. # # The \verb+Shell+ object contains the collection of builtin functions # available as shell commands. # # You can define aliases by extending this object with additional methods. # All methods in this class are called with one argument: a single array # containing an argument list. # # \begin{itemize} # \end{doc} # Shell. += class Shell extends $(Object) # # \begin{doc} # \itemidx{echo} # # The \verb+echo+ function prints its arguments to the standard output channel. # \end{doc} # echo = $(echo) # # \begin{doc} # \itemidx{jobs} # # The \verb+jobs+ method prints the status of currently running commands. # \end{doc} # jobs = $(jobs) getpwnam = $(getpwnam) getpwuid = $(getpwuid) getgrnam = $(getgrnam) getgrgid = $(getgrgid) # # \begin{doc} # \itemidx{cd} # # The \verb+cd+ function changes the current directory. # Note that the current directory follows the usual scoping # rules. For example, the following program lists the # files in the \verb+foo+ directory, but the current # directory is not changed. # # \begin{verbatim} # section # echo Listing files in the foo directory... # cd foo # ls # # echo Listing files in the current directory... # ls # \end{verbatim} # \end{doc} # cd = $(cd) # # \begin{doc} # \itemidx{bg} # # The \verb+bg+ method places a job in the background. # The job is resumed if it has been suspended. # \end{doc} # bg = $(bg) # # \begin{doc} # \itemidx{fg} # # The \verb+fg+ method brings a job to the foreground. # The job is resumed if it has been suspended. # \end{doc} # fg = $(fg) # # \begin{doc} # \itemidx{stop} # # The \verb+stop+ method suspends a running job. # \end{doc} # stop = $(stop) # # \begin{doc} # \itemidx{wait} # # The \verb+wait+ function waits for a running job to terminate. # It is not possible to wait for a suspended job. # # The job is not brought to the foreground. If the \verb+wait+ # is interrupted, the job continues to run in the background. # \end{doc} # wait = $(wait) # # \begin{doc} # \itemidx{kill} # # The \verb+kill+ function signal a job. # # \verb+kill [signal] +. # # The signals are either numeric, or symbolic. # The symbolic signals are named as follows. # # ABRT, ALRM, HUP, ILL, KILL, QUIT, SEGV, TERM, USR1, # USR2, CHLD, STOP, TSTP, TTIN, TTOU, VTALRM, PROF. # \end{doc} # kill = $(kill) # # \begin{doc} # \itemidx{exit} # # The \verb+exit+ function terminates the current session. # \end{doc} # exit = $(exit-parent) # # \begin{doc} # \itemtwoidx{which}{where} # # See the documentation for the corresponding functions. # \end{doc} which(argv) = println($(which $(argv))) where(argv) = res[] = $(where $(argv)) res.map($(println)) return $(int 0) # # \begin{doc} # \itemidx{rehash} # # Reset the search path. # \end{doc} # rehash(argv) = rehash() # # \begin{doc} # \itemidx{ln-or-cp} \em{src} \em{dst} # # Links or copies \em{src} to \em{dst}, overwriting \em{dst}. Namely, \verb+ln-or-cp+ would first # delete the \em{dst} file (unless it is a directory), if it exists. Next it would try to create # a symbolic link \em{dst} poiting to \em{src} (it will make all the necessary adjustmnents of # relative paths). If symbolic link can not be created (\emph{e.g.} the OS or the filesystem does # not support symbolic links), it will try to create a hard link. If that fails too, it will try # to forcibly copy \em{src} to \em{dst}. # \end{doc} # ln-or-cp(argv) = if $(not $(eq $(length $(argv)), 2)) eprintln($"Shell.ln-or-cp: expected 2 arguments, received $(length $(argv)) arguments") exit(1) src = $(file $"$(nth 0, $(argv))") dst = $(file $"$(nth 1, $(argv))") if $(and $(test -e $(dst)), $(not $(test -d $(dst)))) rm($(array -f, $(dst))) if $(test -e $(dst)) # The dst might be read-only; on Windows this will prevent deletion. # Will try to fix the permissions and rm again. # If dst and src are already hardliked, this will break # the permissions on src, so we will try to restore them. src_was_ro = $(not $(test -w $(src))) chmod -f -m u+w $(dst) rm($(array -f, $(dst))) if $(and $(src_was_ro), $(test -w $(src))) chmod -f -m u-w $(src) try symlink($(src), $(dst)) default try link($(src), $(dst)) default if $(and $(test -e $(dst)), $(not $(test -d $(dst)))) # NB: $(dst) might already be a hardlink and we failed to delete it # Trying to cp in that case might cause both $(src) and $(dst) to # get truncated! eprintln($"ln-or-cp: failed to remove the destination file $(dst) before overwriting; giving up.") exit(1) return $(cp $(array -f, $(src), $(dst))) # # \begin{doc} # \itemidx{history} # # Print the current command-line history. # \end{doc} # history(argv) = lines = $(public.history) lines.map($(println)) return $(int 0) # # \begin{doc} # \itemidx{digest} # # Print the digests of the given files. # \end{doc} # digest(argv) = foreach(n => ..., $(argv)) println($"$n: $(digest $n)") value # # \begin{doc} # \item Win32 functions. # # Win32 doesn't provide very many programs for scripting, except # for the functions that are builtin to the DOS \verb+cmd.exe+. # The following functions are defined on Win32 and only on Win32. # On other systems, it is expected that these programs already # exist. # # \begin{itemize} # \end{doc} # if $(equal $(OSTYPE), Win32) # # \begin{doc} # \itemidx{grep} # # \begin{verbatim} # grep [-q] [-n] [-v] [-h] pattern files... # \end{verbatim} # # The \verb+grep+ alias calls the \Prog{omake}'s internal \hyperfun{grep}. # \end{doc} # grep = $(builtin-grep) export # # \begin{doc} # \end{itemize} # \end{doc} # # # \begin{doc} Internal versions of standard system commands. # # By default, \Prog{omake} uses internal versions of the following commands: # \verb+cp+, \verb+mv+, \verb+cat+, \verb+rm+, \verb+mkdir+, \verb+chmod+, # \verb+test+, \verb+find+. # If you really want to use the standard system versions of these # commands, set the \verb+USE_SYSTEM_COMMANDS+ as one of the first # definitions in your \verb+OMakeroot+ file. # # \begin{itemize} # \end{doc} # declare [ declare true if $(not $(defined USE_SYSTEM_COMMANDS)) # # \begin{doc} # \itemidx{pwd} # # \begin{verbatim} # pwd # \end{verbatim} # # The \verb+pwd+ alias would print the absolute path to current directory. # \end{doc} # pwd(argv) = println($(absname .)) # # \begin{doc} # \itemidx{mkdir} # # \begin{verbatim} # mkdir [-m ] [-p] files # \end{verbatim} # # The \verb+mkdir+ function is used to create directories. # The -verb+-m+ option can be used to specify the permission # mode of the created directory. If the \verb+-p+ option # is specified, the full path is created. # \end{doc} # mkdir = $(mkdir) # # \begin{doc} # \itemtwoidx{cp}{mv} # # \begin{verbatim} # cp [-f] [-i] [-v] src dst # cp [-f] [-i] [-v] files dst # mv [-f] [-i] [-v] src dst # mv [-f] [-i] [-v] files dst # \end{verbatim} # # The \verb+cp+ function copies a \verb+src+ file to # a \verb+dst+ file, overwriting it if it already exists. # If more than one source file is specified, the final file # must be a directory, and the source files are copied # into the directory. # # \begin{description} # \item[-f] Copy files forcibly, do not prompt. # \item[-i] Prompt before removing destination files. # \item[-v] Explain what is happening. # \end{description} # \end{doc} # cp = $(cp) mv = $(mv) # # \begin{doc} # \itemidx{rm} # # \begin{verbatim} # rm [-f] [-i] [-v] [-r] files # rmdir [-f] [-i] [-v] [-r] dirs # \end{verbatim} # # The \verb+rm+ function removes a set of files. # No warnings are issued if the files do not exist, or if # they cannot be removed. # # Options: # \begin{description} # \item[-f] Forcibly remove files, do not prompt. # \item[-i] Prompt before removal. # \item[-v] Explain what is happening. # \item[-r] Remove contents of directories recursively. # \end{description} # \end{doc} # rm = $(rm) rmdir = $(rmdir) # # \begin{doc} # \itemidx{chmod} # # \begin{verbatim} # chmod [-r] [-v] [-f] mode files # \end{verbatim} # # The \verb+chmod+ function changes the permissions on a set of # files or directories. This function does nothing on Win32. # The \verb+mode+ may be specified as an octal number, # or in symbolic form \verb+[ugoa]*[+-=][rwxXstugo]+. # See the man page for \verb+chmod+ for details. # # Options: # \begin{description} # \item[-r] Change permissions of all files in a directory recursively. # \item[-v] Explain what is happening. # \item[-f] Continue on errors. # \end{description} # \end{doc} # chmod = $(chmod) # # \begin{doc} # \itemidx{cat} # # \begin{verbatim} # cat files... # \end{verbatim} # # The \verb+cat+ function prints the contents of the files to stdout # \end{doc} # cat(argv)= print($(cat $(argv))) # # \begin{doc} # \itemidx{test} # # \verb+test+ \emph{expression}\\ # \verb+[+ \emph{expression} +]+\\ # \verb+[ --help+\\ # \verb+[ --version+\\ # # See the documentation for the \hyperfun{test}. # # \end{doc} # test = $(builtin-test) [ = $(builtin-test-brack) # # \begin{doc} # \itemidx{find} # # \verb+find+ \emph{expression} # # See the documentation for the \hyperfun{find}. # # \end{doc} # find = $(builtin-find) true(argv) = return true export # # \begin{doc} # \end{itemize} # \end{doc} # # # \begin{doc} # \end{itemize} # \end{doc} # # # These are all documented in Omake_builtin_io_fun. # declare parse-loc Token. = class Token loc = name = val = unit(name) = this.loc = $(parse-loc) this.name = $(name) return $(this) pair(name, val) = this.loc = $(parse-loc) this.name = $(name) this.val = $(val) return $(this) rename(name) = this.name = $(name) return $(this) Lexer. += class Lexer extends $(Object) declare channel # # For interpreting the rules # rule = $(lex-rule) # # To use a lexer, you would normally hand it a channel # from-channel(channel) = this.channel = $(channel) return $(this) lex() = return $(lex-engine $(this.channel)) lex-channel(channel) = this.channel = $(channel) return $(lex-engine $(channel)) set-line(filename, line) = set-channel-line($(channel), $(filename), $(line)) Parser. += class Parser extends $(Object) # # For interpreting the rules # rule = $(parse-rule) # # You must set the lexer # lexer = # # Start symbols # start = $(parse-start) # # Precedence operations # left = $(parse-left) right = $(parse-right) nonassoc = $(parse-nonassoc) # # Manipulating the current precedence level # prec-min = $".min" prec-max = $".max" current-prec = $".min" # # Build the parser # build = $(parse-build) # # Main parsing function # parse(sym) = return $(parse-engine $(sym)) parse-channel(sym, channel) = lexer = $(lexer.from-channel $(channel)) return $(parse-engine $(sym)) parse-file(sym, file) = channel = $(fopen $(file), r) lexer = $(lexer.from-channel $(channel)) result = $(parse-engine $(sym)) close($(channel)) return $(result) omake-0.10.3/lib/boot/0000755000175000017500000000000013177364666013047 5ustar gerdgerdomake-0.10.3/lib/boot/Default0000644000175000017500000001005313177364666014355 0ustar gerdgerdOMakeroot = $(License)$''' ######################################################################## # The standard OMakeroot file. # You will not normally need to modify this file. # By default, your changes should be placed in the # OMakefile in this directory. # # If you decide to modify this file, note that it uses exactly # the same syntax as the OMakefile. # # # Include the standard installed configuration files. # Any of these can be deleted if you are not using them, # but you probably want to keep the Common file. # open build/C open build/OCaml open build/LaTeX # # The command-line variables are defined *after* the # standard configuration has been loaded. # DefineCommandVars() # # Include the OMakefile in this directory. # .SUBDIRS: . ''' ######################################################################## ######################################################################## ######################################################################## OMakefile = $(License)$""" ######################################################################## # The standard OMakefile. # You will usually need to modify this file for your project. # Delete this line once you have configured this file eprintln($$(CWD)/OMakefile is not configured) ######################################################################## # Phony targets are scoped, so you probably want to declare them first. # # .PHONY: all install clean ######################################################################## # Subdirectories. # You may want to include some subdirectories in this project. # If so, define the subdirectory targets and uncomment this section. # # .SUBDIRS: ######################################################################## # C configuration. # Delete this section if you are not building C files. # ################################################ # Configuration. You might want to modify any of these # configuration variables. # # CFLAGS += # ASFLAGS += # LDFLAGS += # INCLUDES += ################################################ # Uncomment the following section if you want # to build a C program in the current directory. # # CFILES[] = # file1 # main # # MAIN = main # # .DEFAULT: $$(CProgram $$(MAIN), $$(CFILES)) ################################################ # Uncomment the following section if you want to build a C library # in the current directory. # # LIBFILES[] = # file1 # file2 # # LIB = libxxx # # .DEFAULT: $$(StaticCLibrary $$(LIB), $$(LIBFILES)) ######################################################################## # OCaml configuration. # Delete this section if you are not building OCaml files. # ################################################ # Configuration. You may want to modify any of these configuration # variables. # # # This project requires ocamlfind (default - false). # # USE_OCAMLFIND = true # # OCAMLPACKS[] = # pack1 # pack2 # # if $$(not $$(OCAMLFIND_EXISTS)) # eprintln(This project requires ocamlfind, but is was not found.) # eprintln(You need to install ocamlfind and run "omake --configure".) # exit 1 # # Include path # # OCAMLINCLUDES += # # Compile native or byte code? # # The default values are defined as follows: # # NATIVE_ENABLED = $$(OCAMLOPT_EXISTS) # BYTE_ENABLED = $$(not $$(OCAMLOPT_EXISTS)) # # Various options # # OCAMLFLAGS += # OCAMLCFLAGS += # OCAMLOPTFLAGS += # OCAML_LINK_FLAGS += # OCAML_BYTE_LINK_FLAGS += # OCAML_NATIVE_LINK_FLAGS += ################################################ # Generated files # # Workaround for the fact that ocamldep does not pay attention to .mll # and .mly files. # # OCamlGeneratedFiles(parser.ml lexer.ml) ################################################ # Build an OCaml library # # FILES[] = # file1 # file2 # # LIB = main # # .DEFAULT: $$(OCamlLibrary $$(LIB), $$(FILES)) ################################################ # Build an OCaml program # # FILES[] = # file1 # file2 # # PROGRAM = # OCAML_LIBS += # OCAML_CLIBS += # OCAML_OTHER_LIBS += # OCAML_LIB_FLAGS += # # .DEFAULT: $$(OCamlProgram $$(PROGRAM), $$(FILES)) """ omake-0.10.3/lib/boot/License0000644000175000017500000000164413177364666014361 0ustar gerdgerdLicense = $"""######################################################################## # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the # File is furnished to do so, subject to the following condition: # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, # DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR # OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE FILE OR # THE USE OR OTHER DEALINGS IN THE FILE. """ omake-0.10.3/lib/build/0000755000175000017500000000000013177364666013203 5ustar gerdgerdomake-0.10.3/lib/build/C.install0000644000175000017500000006254113177364666014765 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) ######################################################################## # Building C files. # # Copyright (C) 2003-2007 Jason Hickey and Mojave Group # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. open build/Common open configure/Configure # # \begin{doc} # \section{Building C and C++ code} # # \OMake{} provides extensive support for building C and C++ programs. In order to use the functions # defined in this section, you need to make sure the line # \begin{verbatim} # open build/C # \end{verbatim} # is present in your \verb+OMakeroot+ file. # # \subsection{Autoconfiguration variables} # These variables will get defined based on the ``autoconf-style'' \verb+static.+ tests executed # when you run \OMake{} for the first time. You can use them to configure your project accordingly, # and you should not redefine them. # # You can use the \verb+--configure+ command line option (Section~\ref{option:--configure}) to force # re-execution of all the tests. # # A different set of autoconfiguration tests is performed depending on the build environment # involved --- one set of tests would be performed in a \verb+Win32+ environment, and another --- # in a Unix-like environment (including Linux, OS X and Cygwin). # # \subsubsection{Unix-like systems} # \varlabel{GCC_FOUND}{GCC\_FOUND} A boolean flag specifying whether the \verb+gcc+ binary was found in your path. # \varlabel{GXX_FOUND}{GXX\_FOUND} A boolean flag specifying whether the \verb.g++. binary was found in your path. # # \subsubsection{Win32} # \varlabel{CL_FOUND}{CL\_FOUND} A boolean flag specifying whether the \verb+cl+ binary was found in your path. # \varlabel{LIB_FOUND}{LIB\_FOUND} A boolean flag specifying whether the \verb+lib+ binary was found in your path. # # \subsection{C and C++ configuration variables} # # The following variables can be redefined in your project. # # \var{CC} The name of the C compiler (on \verb+Unix+ it defaults to \verb+gcc+ when \verb+gcc+ is present and # to \verb+cc+ otherwise; on \verb+Win32+ defaults to \verb+cl /nologo+). # \var{CXX} The name of the C++ compiler (on \verb+Unix+ it defaults to \verb+gcc+ when \verb+gcc+ is present # and to \verb+c+++ otherwise; on \verb+Win32+ defaults to \verb+cl /nologo+). # \var{CPP} The name of the C preprocessor (defaults to \verb+cpp+ on \verb+Unix+, and \verb+cl /E+ on \verb+Win32+). # \var{CFLAGS} Compilation flags to pass to the C compiler (default empty on \verb+Unix+, and \verb+/DWIN32+ # on \verb+Win32+). # \var{CXXFLAGS} Compilation flags to pass to the C++ compiler (default empty on \verb+Unix+, and \verb+/DWIN32+ # on \verb+Win32+). # \var{INCLUDES} Additional directories that specify the search path to the C and C++ compilers (default is \verb+.+). # The directories are passed to the C and C++ compilers with the \verb+-I+ option. # The include path with \verb+-I+ prefixes is defined in the \verb+PREFIXED_INCLUDES+ variable. # \var{LIBS} Additional libraries needed when building a program (default is empty). # \var{CCOUT} The option to use for specifying the output file in C and C++ compilers # (defaults to \verb+-o+ on \verb+Unix+ and \verb+/Fo+ on \verb+Win32+). # \var{AS} The name of the assembler (defaults to \verb+as+ on \verb+Unix+, and \verb+ml+ on \verb+Win32+). # \var{ASFLAGS} Flags to pass to the assembler (default is empty on \verb+Unix+, and \verb+/c /coff+ # on \verb+Win32+). # \var{ASOUT} The option string that specifies the output file for \verb+AS+ (defaults to \verb+-o+ # on \verb+Unix+ and \verb+/Fo+ on \verb+Win32+). # \var{AR} The name of the program to create static libraries (defaults to \verb+ar cq+ on \verb+Unix+, # and \verb+lib+ on \verb+Win32+). # \var{LD} The name of the linker (defaults to \verb+ld+ on \verb+Unix+, and \verb+cl+ on \verb+Win32+). # \var{LDFLAGS} Options to pass to the linker (default is empty). # \varlabel{LDFLAGS_DLL}{LDFLAGS\_DLL} Options to pass to the linker when compiling a shared library (defaults to \verb+-shared+ on \verb+Unix+ and \verb+/DLL+ on \verb+Win32+). # \var{LDOUT} The option to use for specifying the output file in C and C++ linkers # (defaults to \verb+-o+ on \verb+Unix+ and \verb+/Fe+ on \verb+Win32+). # \var{YACC} The name of the \verb+yacc+ parser generator (default is \verb+yacc+ on \verb+Unix+, empty on \verb+Win32+). # \var{LEX} The name of the \verb+lex+ lexer generator (default is \verb+lex+ on \verb+Unix+, empty on \verb+Win32+). # \end{doc} # # derive a toolchain name, e.g. # toolchain-derive(foo-gcc, g++, fallback) = "foo-g++" # if foo-g++ exists, and fallback otherwise protected.toolchain-derive(cc, command, fallback) = empty = $(array) match $(cc) case $"\(.*\)-g?cc" fullcmd = $(concat $(empty), $1 $(command)) if $(exists-in-path $(fullcmd)) return $(fullcmd) else return $(fallback) default return $(fallback) # by default, we pick the C compiler that was used for building omake. # When upgrading omake, this might not be set, so fall back to the old # magic. .STATIC: # C compiler if $(equal $(CCOMPTYPE), msvc) CL_FOUND = $(CheckProg cl) LIB_FOUND = $(CheckProg lib) export else protected.GCC_FOUND1 = $(CheckProg gcc) protected.GXX_FOUND1 = $(and $(GCC_FOUND1), $(CheckProg g++)) export if $(defined OMAKE_CC) DEFAULT_CC = $(OMAKE_CC) export else if $(equal $(CCOMPTYPE), msvc) DEFAULT_CC = cl export else DEFAULT_CC = $(if $(GCC_FOUND1), gcc, cc) export export DEFAULT_CC_FOUND = $(CheckProg $(DEFAULT_CC)) DEFAULT_GCC_FOUND = false match $(DEFAULT_CC) case $"\.*-gcc" DEFAULT_GCC_FOUND = true export case $"gcc" DEFAULT_GCC_FOUND = true export if $(equal $(CCOMPTYPE), msvc) DEFAULT_CC += /nologo export # C++ compiler if $(equal $(CCOMPTYPE), msvc) DEFAULT_CXX = cl /nologo export else DEFAULT_CXX = $(toolchain-derive $(DEFAULT_CC), g++, $`(toolchain-derive $(DEFAULT_CC), c++, $(if $(GXX_FOUND1), g++, c++))) export DEFAULT_CXX_FOUND = $(CheckProg $(nth 0, $(DEFAULT_CXX))) DEFAULT_GXX_FOUND = false match $(DEFAULT_CXX) case $"\.*-g++" DEFAULT_GXX_FOUND = true export case $"g++" DEFAULT_GXX_FOUND = true export # C preprocessor if $(equal $(CCOMPTYPE), msvc) DEFAULT_CPP = cl /nologo /E export else DEFAULT_CPP = $(toolchain-derive $(DEFAULT_CC), cpp, $(DEFAULT_CC) -E) export DEFAULT_CPP_FOUND = $(CheckProg $(nth 0, $(DEFAULT_CPP))) # linker if $(equal $(CCOMPTYPE), msvc) DEFAULT_LD = cl /nologo export else DEFAULT_LD = $(toolchain-derive $(DEFAULT_CC), ld, ld) export DEFAULT_LD_FOUND = $(CheckProg $(nth 0, $(DEFAULT_LD))) # assembler if $(equal $(CCOMPTYPE), msvc) DEFAULT_AS = ml /nologo export else DEFAULT_AS = $(toolchain-derive $(DEFAULT_CC), as, as) export DEFAULT_AS_FOUND = $(CheckProg $(nth 0, $(DEFAULT_AS))) export # At this point you could insert code updating DEFAULT_CC. declare protected.CC_DEFINE declare protected.OS_CFLAGS if $(equal $(CCOMPTYPE), msvc) CC_DEFINE = /D export else CC_DEFINE = -D export if $(equal $(OSTYPE), Win32) OS_CFLAGS = $(CC_DEFINE)WIN32 public.CDLL_IMPLIES_STATIC = true export else OS_CFLAGS = public.CDLL_IMPLIES_STATIC = false export if $(equal $(CCOMPTYPE), msvc) public.CC = $(DEFAULT_CC) public.CXX = $(DEFAULT_CXX) public.CPP = $(DEFAULT_CPP) public.CFLAGS = $(OS_CFLAGS) public.CXXFLAGS = $(OS_CFLAGS) public.AR(name) = return(lib /nologo /debugtype:CV /out:$(name)) public.RANLIB = echo ranlib public.INCLUDES[] = . public.INCLUDES_OPT = /I public.CCOUT = /Fo public.LD = $(DEFAULT_LD) public.YACC = echo yacc public.LEX = echo lex public.LIBS = public.LDFLAGS = public.LDFLAGS_DLL = /DLL public.LDOUT = /Fe public.AS = $(DEFAULT_AS) public.ASOUT = /Fo public.ASFLAGS = /c /coff export else public.CC = $(DEFAULT_CC) public.GCC_FOUND = $(DEFAULT_GCC_FOUND) public.CXX = $(DEFAULT_CXX) public.GXX_FOUND = $(DEFAULT_GXX_FOUND) public.CPP = $(DEFAULT_CPP) public.CFLAGS = $(OS_CFLAGS) public.CXXFLAGS = $(OS_CFLAGS) public.AR(name) = return(ar cq $(name)) public.RANLIB = ranlib public.LD = $(DEFAULT_LD) public.INCLUDES[] = . public.INCLUDES_OPT = -I public.CCOUT = $(array -o) public.YACC = yacc public.LEX = lex public.LIBS = public.LDFLAGS = public.LDOUT = $(array -o) # MacOS X specific config if $(equal $(SYSNAME), Darwin) public.LDFLAGS_DLL = -dynamiclib export else public.LDFLAGS_DLL = -shared export public.AS = $(DEFAULT_AS) public.ASOUT = $(array -o) public.ASFLAGS = export # # Add the -I option to the includes lazily. # Don't redefine this variable unless you know what you are doing. # public.PREFIXED_INCLUDES = $`(addprefix $(INCLUDES_OPT), $(INCLUDES)) # # Special flags for compiling C files for use in OCaml # public.BYTE_CFLAGS = public.NATIVE_CFLAGS = # # Generic build rules # # public.CXX_EXTS[] = .cpp .cc .c++ %$(EXT_OBJ): %.c :scanner: scan-c-%.c $(CC) $(CFLAGS) $(PREFIXED_INCLUDES) -c $(CCOUT)$@ $< foreach(CXX_EXT => ..., $(CXX_EXTS)) %$(EXT_OBJ): %$(CXX_EXT) :scanner: scan-cxx-%$(CXX_EXT) $(CXX) $(CXXFLAGS) $(PREFIXED_INCLUDES) -c $(CCOUT)$@ $< export %$(EXT_OBJ): %$(EXT_ASM) $(AS) $(ASFLAGS) $(PREFIXED_INCLUDES) $(ASOUT)$@ $< %.c: %.y $(YACC) $< %.c: %.l $(LEX) $< # # Default C scanner # # # Make sure generated files are built before scanning # # \begin{doc} # \subsection{Generated C files} # Because the C scanners do not normally know anything about generated source files (such as # generated header files), these files may need to be created before running the scanner. # \twofuns{CGeneratedFiles}{LocalCGeneratedFiles} # \begin{verbatim} # CGeneratedFiles(files) # LocalCGeneratedFiles(files) # \end{verbatim} # # The \verb+CGeneratedFiles+ and \verb+LocalCGeneratedFiles+ functions specify files # that need to be generated before any C files are scanned for dependencies. For example, # if \verb+config.h+ and \verb+inputs.h+ are both generated files, specify: # \begin{verbatim} # CGeneratedFiles(config.h inputs.h) # \end{verbatim} # # The \verb+CGeneratedFiles+ function is \emph{global} --- its arguments will be generated # before any C files anywhere in the project are scanned for dependencies. The # \verb+LocalCGeneratedFiles+ function follows the normal scoping rules of OMake. # # \end{doc} # .PHONY: CGeneratedFilesTarget public.CGeneratedFiles(files) = CGeneratedFilesTarget: $(files) public.LocalCGeneratedFiles(files) = .SCANNER: scan-c-%: $(files) .SCANNER: scan-cxx-%: $(files) .SCANNER: %$(EXT_OBJ): $(files) export # # We use digest-path-exists value dependency to make sure the SCANNER is re-run # whenever the scanned dependencies change. # if $(equal $(CCOMPTYPE), msvc) Shell. += builtin-cc-depend(argv) = filename = $(nth 0, $(argv)) depends[] = awk(b, $(stdin)) case $'Note:.*including file: *\(.*\)$' depends[] += $(file $"$1") export case $'Hinweis:.*Einlesen der Datei: *\(.*\)$' depends[] += $(file $"$1") export case $'.[(][0-9][0-9]*[)] : (warning|(fatal |)error) [A-Z][0-9]*: ' eprintln($0) depends = $(string-escaped $(set $(depends))) objname = $(string-escaped $(rootname $(filename))$(EXT_OBJ)) println($"$(objname): $(depends)") .SCANNER: scan-c-%.c: %.c /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) $(CC) $(CFLAGS) $(PREFIXED_INCLUDES) /w /Zs /showIncludes $< |& builtin-cc-depend $< # # Include default rule for backwards-compatibility # .SCANNER: %$(EXT_OBJ): %.c /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) # $(CC) $(CFLAGS) $(PREFIXED_INCLUDES) /Zs /showIncludes $< |& builtin-cc-depend $< foreach(CXX_EXT => ..., $(CXX_EXTS)) .SCANNER: scan-cxx-%$(CXX_EXT): %$(CXX_EXT) /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) $(CXX) $(CXXFLAGS) $(PREFIXED_INCLUDES) /w /Zs /showIncludes $< |& builtin-cc-depend $< # # Include default rule for backwards-compatibility # .SCANNER: %$(EXT_OBJ): %$(CXX_EXT) /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) # $(CXX) $(CXXFLAGS) $(PREFIXED_INCLUDES) /Zs /showIncludes $< |& builtin-cc-depend $< export export else .SCANNER: scan-c-%.c: %.c /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) $(CC) $(CFLAGS) $(PREFIXED_INCLUDES) -MM $< # # Include default rule for backwards-compatibility # .SCANNER: %$(EXT_OBJ): %.c /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) # $(CC) $(CFLAGS) $(PREFIXED_INCLUDES) -MM $< foreach(CXX_EXT => ..., $(CXX_EXTS)) .SCANNER: scan-cxx-%$(CXX_EXT): %$(CXX_EXT) /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) $(CXX) $(CXXFLAGS) $(PREFIXED_INCLUDES) -MM $< # # Include default rule for backwards-compatibility # .SCANNER: %$(EXT_OBJ): %$(CXX_EXT) /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) # $(CXX) $(CXXFLAGS) $(PREFIXED_INCLUDES) -MM $< export export # Define a function to build a C-library # # \begin{doc} # \subsection{Building C programs and Libraries} # \twofuns{StaticCLibrary}{DynamicCLibrary} # # The \verb+StaticCLibrary+ builds a static library and the \verb+DynamicCLibrary+ # function builds a shared library (DLL). # # \begin{verbatim} # StaticCLibrary(, ) # DynamicCLibrary(, ) # \end{verbatim} # # The \verb++ does \emph{not} include the library suffix, and # The \verb++ list does not include the object suffix. These # are obtained from the \hypervarxn{EXT_LIB}{EXT\_LIB} (\hypervarxn{EXT_DLL}{EXT\_DLL}) # and \hypervarxn{EXT_OBJ}{EXT\_OBJ} variables. # # This function returns the library filename. # # The following command builds the library \verb+libfoo.a+ from the # files \verb+a.o b.o c.o+ on \verb+Unix+, or the library # \verb+libfoo.lib+ from the files \verb+a.obj b.obj c.obj+ # on \verb+Win32+. # # \begin{verbatim} # StaticCLibrary(libfoo, a b c) # .DEFAULT: $(StaticCLibrary libbar, a b c d) # \end{verbatim} # # \varlabel{CDLL_IMPLIES_STATIC}{CDLL\_IMPLIES\_STATIC} If the \verb+CDLL_IMPLIES_STATIC+ # variable is enabled (this is default on \verb+Win32+), all the \verb+DynamicC+ functions # would assume that creating a shared library automatically created a static one. # \end{doc} # public.StaticCLibrary(name, files) = private.OFILES = $(addsuffix $(EXT_OBJ), $(files)) private.NORMALLIB = $(file $(name)$(EXT_LIB)) if $(equal $(OSTYPE), Win32) $(NORMALLIB): $(OFILES) echo $(OFILES) > $@.tmp $(AR $@) @$@.tmp rm -f $@.tmp else $(NORMALLIB): $(OFILES) rm -f $@ $(AR $@) $(OFILES) $(RANLIB) $@ return $(NORMALLIB) public.DynamicCLibrary(name, files) = private.OFILES = $(addsuffix $(EXT_OBJ), $(files)) private.LFILES = $(addsuffix $(EXT_LIB), $(LIBS)) private.LIB = $(file $(name)$(EXT_DLL)) private.TARGETS = $(LIB) if $(CDLL_IMPLIES_STATIC) TARGETS[] += $(file $(name)$(EXT_LIB)) export TARGETS $(TARGETS): $(OFILES) $(LFILES) $(CC) $(CFLAGS) $(LDOUT)$(LIB) $(OFILES) $(LFILES) $(LDFLAGS) $(LDFLAGS_DLL) return $(TARGETS) # # Copy to an install directory # # \begin{doc} # \twofuns{StaticCLibraryCopy}{DynamicCLibraryCopy} # # The \verb+StaticCLibraryCopy+ and \verb+DynamicCLibraryCopy+ functions copy a library # to an install location. # # \begin{verbatim} # StaticCLibraryCopy(, , ) # DynamicCLibraryCopy(, , ) # \end{verbatim} # # The \verb++ is the name of a target (typically a \verb+.PHONY+ target); # the \verb++ is the installation directory, and \verb++ is # the library to be copied (without the library suffix). # # This function returns the filename of the library in the target directory. # # For example, the following code copies the library # \verb+libfoo.a+ to the \verb+/usr/lib+ directory. # # \begin{verbatim} # .PHONY: install # # StaticCLibraryCopy(install, /usr/lib, libfoo) # \end{verbatim} # \end{doc} # public.StaticCLibraryCopy(tag, lib, name) = # # Names of libs # private.NORMALLIB = $(file $(name)$(EXT_LIB)) private.LIBNORMAL = $(file $(lib)/$(basename $(name))$(EXT_LIB)) # # Linking the library into the root lib dir # $(LIBNORMAL): $(NORMALLIB) $(lib) :scanner: $(NOSCANNER) ln-or-cp $< $@ # # Add dependency to the tag # $(tag): $(LIBNORMAL) return $(LIBNORMAL) public.DynamicCLibraryCopy(tag, lib, name) = TARGETS = EXT_LIB = $(EXT_DLL) value $(StaticCLibraryCopy $(tag), $(lib), $(name)) if $(CDLL_IMPLIES_STATIC) TARGETS[] += $(StaticCLibraryCopy $(tag), $(lib), $(name)) export TARGETS return $(TARGETS) # # We often use them together # # \begin{doc} # \twofuns{StaticCLibraryInstall}{DynamicCLibraryInstall} # # The \verb+StaticCLibraryInstall+ and \verb+DynamicCLibraryInstall+ functions build a library, and # set the install location in one step. Return the filename of the library # in the target directory. # # \begin{verbatim} # StaticCLibraryInstall(, , , ) # DynamicCLibraryInstall(, , , ) # \end{verbatim} # # \begin{verbatim} # StaticCLibraryInstall(install, /usr/lib, libfoo, a b c) # \end{verbatim} # \end{doc} # public.StaticCLibraryInstall(tag, lib, name, files) = StaticCLibrary($(name), $(files)) return $(StaticCLibraryCopy $(tag), $(lib), $(name)) public.DynamicCLibraryInstall(tag, lib, name, files) = DynamicCLibrary($(name), $(files)) return $(DynamicCLibraryCopy $(tag), $(lib), $(name)) # # Build a .o file. This is like a library, # but use the linker instead. # # \begin{doc} # \threefuns{StaticCObject}{StaticCObjectCopy}{StaticCObjectInstall} # # These functions mirror the \verb+StaticCLibrary+, \verb+StaticCLibraryCopy+, # and \verb+StaticCLibraryInstall+ functions, but they build an \emph{object} # file (a \verb+.o+ file on \verb+Unix+, and a \verb+.obj+ file on \verb+Win32+). # \end{doc} # public.StaticCObject(name, files) = # # Generic library that can be used on byte and native-code # private.OFILES = $(addsuffix $(EXT_OBJ), $(files)) # # Names of libs # private.NORMALLIB = $(file $(name)$(EXT_OBJ)) $(NORMALLIB): $(OFILES) $(LD) $(LDFLAGS) -r $(LDOUT)$@ $(OFILES) return $(NORMALLIB) # # Copy to an install directory # public.StaticCObjectCopy(tag, lib, name) = # # Names of libs # private.NORMALLIB = $(file $(name)$(EXT_OBJ)) private.LIBNORMAL = $(file $(lib)/$(basename $(name))$(EXT_OBJ)) # # Linking the library into the root lib dir # $(LIBNORMAL): $(NORMALLIB) $(lib) :scanner: $(NOSCANNER) ln-or-cp $< $@ # # Add dependency to the tag # $(tag): $(LIBNORMAL) return $(LIBNORMAL) # # We often use them together # public.StaticCObjectInstall(tag, lib, name, files) = StaticCObject($(name), $(files)) return $(StaticCObjectCopy $(tag), $(lib), $(name)) # # Define a function to build a C-program # # \begin{doc} # \fun{CProgram} # # The \verb+CProgram+ function builds a C program from a set # of object files and libraries. # # \verb+CProgram(, )+ # # The \verb++ argument specifies the name of the program to be built; # the \verb++ argument specifies the files to be linked. The function # returns the filename of the executable. # # Additional options can be passed through the following variables. # \begin{description} # \item[CFLAGS] Flags used by the C compiler during the link step. # \item[LDFLAGS] Flags to pass to the loader. # \item[LIBS] Additional libraries to be linked. # \end{description} # # For example, the following code specifies that the program # \verb+foo+ is to be produced by linking the files \verb+bar.o+ # and \verb+baz.o+ and libraries \verb+libfoo.a+. # # \begin{verbatim} # section # LIBS = libfoo # LDFLAGS += -lbar # CProgram(foo, bar baz) # \end{verbatim} # \end{doc} # public.CProgram(name, files) = # # Generic program # private.OFILES = $(addsuffix $(EXT_OBJ), $(files)) private.NAME = $(file $(name)$(EXE)) # # XXX: Backward compatibility: We used to confuse LIBS and LDFLAGS, so need to split things out. # private.FLAGS = $(filter -%, $(LIBS)) if $(FLAGS) eprintln($""!!! WARNING: the LIBS variable should not include link flags "$(FLAGS)";"") eprintln($""!!! those should go into LDFLAGS"") LDFLAGS += $(FLAGS) LIBS = $(filter-out -%, $(LIBS)) export if $(filter %$(EXT_LIB), $(LIBS)) eprintln($""!!! WARNING: the LIBS variable should contain libraries _without_ extensions."") LIBS = $(replacesuffixes $(EXT_LIB), $"$(EMPTY)", $(LIBS)) export private.LFILES = $(addsuffix $(EXT_LIB), $(LIBS)) $(NAME): $(OFILES) $(LFILES) $(CC) $(CFLAGS) $(LDOUT)$@ $,(OFILES) $(LFILES) $(LDFLAGS) return $(NAME) # # Copy to a bin directory # # \begin{doc} # \fun{CProgramCopy} # # The \verb+CProgramCopy+ function copies a file to an install location. # # \verb+CProgramCopy(, , )+ # # \begin{verbatim} # CProgramCopy(install, /usr/bin, foo) # \end{verbatim} # \end{doc} # public.CProgramCopy(tag, bin, name) = # # Name of the program # private.NAME = $(file $(name)$(EXE)) private.BINNAME = $(file $(bin)/$(basename $(name))$(EXE)) # # Linking the program into the root bin dir # $(BINNAME): $(NAME) $(bin) :scanner: $(NOSCANNER) ln-or-cp $< $@ # # Add the dependency to the tag # $(tag): $(BINNAME) return $(BINNAME) # # We often use them together # # \begin{doc} # \fun{CProgramInstall} # # The \verb+CProgramInstall+ function specifies a program to build, # and a location to install, simultaneously. # # \verb+CProgramInstall(, , , )+ # # \begin{verbatim} # section # LIBS = libfoo # LDFLAGS += -lbar # CProgramInstall(install, /usr/bin, foo, bar baz) # \end{verbatim} # \end{doc} # public.CProgramInstall(tag, bin, name, files) = CProgram($(name), $(files)) return $(CProgramCopy $(tag), $(bin), $(name)) # # The C++ versions. # # \begin{doc} # \twofuns{CXXProgram}{CXXProgramInstall} # # The \verb+CXXProgram+ and \verb+CXXProgramInstall+ functions are # equivalent to their C counterparts, except that would use \verb+$(CXX)+ and \verb+$(CXXFLAGS)+ # for linking instead of \verb+$(CC)+ and \verb+$(CFLAGS)+. # \end{doc} # public.CXXProgram(name, files) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(CProgram $(name), $(files)) public.CXXProgramInstall(tag, bin, name, files) = CXXProgram($(name), $(files)) return $(CProgramCopy $(tag), $(bin), $(name)) # \begin{doc} # \sixfuns{StaticCXXLibrary}{StaticCXXLibraryCopy}{StaticCXXLibraryInstall}{DynamicCXXLibrary}{DynamicCXXLibraryCopy}{DynamicCXXLibraryInstall} # # Similarly, the six \verb+CXXLibrary+ functions the C++ equivalents of the corresponding # \verb+CLibrary+ functions. # \end{doc} # public.StaticCXXLibrary(name, files) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(StaticCLibrary $(name), $(files)) public.StaticCXXLibraryCopy(tag, lib, name) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(StaticCLibraryCopy $(tag), $(lib), $(name)) public.StaticCXXLibraryInstall(tag, lib, name, files) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(StaticCLibraryInstall $(tag), $(lib), $(name), $(files)) public.DynamicCXXLibrary(name, files) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(DynamicCLibrary $(name), $(files)) public.DynamicCXXLibraryCopy(tag, lib, name) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(DynamicCLibraryCopy $(tag), $(lib), $(name)) public.DynamicCXXLibraryInstall(tag, lib, name, files) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(DynamicCLibraryInstall $(tag), $(lib), $(name), $(files)) omake-0.10.3/lib/build/OCaml.install0000644000175000017500000014032213177364666015570 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) ######################################################################## # Building OCaml programs. # # Copyright (C) 2003-2007 Jason Hickey and Mojave Group # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. open build/Common open configure/Configure ######################################################################## # OCaml section # # \begin{doc} # \section{Building OCaml code} # # \OMake{} provides extensive support for building OCaml code, including support for tools like # \verb+ocamlfind+, \verb+ocamlyacc+ and \verb+menhir+. In order to use the functions # defined in this section, you need to make sure the line # \begin{verbatim} # open build/OCaml # \end{verbatim} # is present in your \verb+OMakeroot+ file. # # \subsection{Autoconfiguration variables for OCaml compilation} # These variables will get defined based on the ``autoconf-style'' tests executed when you # run \OMake{} for the first time. You can use them to configure your project accordingly, # and you should not redefine them. # # You can use the \verb+--configure+ command line option (Section~\ref{option:--configure}) to force # re-execution of all the tests. # # \varlabel{OCAMLOPT_EXISTS}{OCAMLOPT\_EXISTS} True when \verb+ocamlopt+ (or \verb+ocamlopt.opt+) is # available on your machine. # \varlabel{OCAMLFIND_EXISTS}{OCAMLFIND\_EXISTS} True when the ocamlfind is available on your # machines. # \varlabel{OCAMLDEP_MODULES_AVAILABLE}{OCAMLDEP\_MODULES\_AVAILABLE} True when a version of # \verb+ocamldep+ that understands the \verb+-modules+ option is available on your machine. # \varlabel{CMXS_SUPPORTED}{CMXS\_SUPPORTED} True if "ocamlopt -shared" is supported by the compiler. # \varlabel{MENHIR_AVAILABLE}{MENHIR\_AVAILABLE} True when the Menhir parser-generator is available # on your machine. # \var{OCAMLLIB} The location of OCaml library directory (output of \verb+ocamlc -where+). Empty when no # ocamlc is found. # # \subsection{Configuration variables for OCaml compilation} # # The following variables can be redefined in your project. # \varlabel{USE_OCAMLFIND}{USE\_OCAMLFIND} Whether to use the \verb+ocamlfind+ utility (default \verb+false+) # \var{OCAMLC} The OCaml bytecode compiler (default \verb+ocamlc.opt+ if it exists # and \verb+USE_OCAMLFIND+ is not set, otherwise \verb+ocamlc+). # \var{OCAMLOPT} The OCaml native-code compiler (default \verb+ocamlopt.opt+ if it # exists and \verb+USE_OCAMLFIND+ is not set, otherwise \verb+ocamlopt+). # \var{CAMLP4} The \verb+camlp4+ preprocessor (default \verb+camlp4+). # \var{OCAMLLEX} The OCaml lexer generator (default \verb+ocamllex+). # \var{OCAMLLEXFLAGS} The flags to pass to \verb+ocamllex+ (default \verb+-q+). # \var{OCAMLYACC} The OCaml parser generator (default \verb+ocamlyacc+). # \var{OCAMLYACCFLAGS} Additional options to pass to \verb+$(OCAMLYACC)+. # \var{OCAMLDEP} The OCaml dependency analyzer (default \verb+ocamldep+). # \varlabel{OCAMLDEP_MODULES_ENABLED}{OCAMLDEP\_MODULES\_ENABLED} Instead of using \verb+OCAMLDEP+ # in a traditional \verb+make+-style fashion, run \verb+$(OCAMLDEP) -modules+ and then # postprocess the output internally to discover all the relevant generated \verb+.ml+ and # \verb+.mli+ files. See Section~\ref{section:ocaml-generated-files} for more information on # interactions between \OMake, \verb+OCAMLDEP+ and generated files. Set to # \verb+$(OCAMLDEP_MODULES_AVAILABLE)+ by default. # \var{OCAMLMKTOP} The OCaml toploop compiler (default \verb+ocamlmktop+). # \var{OCAMLLINK} The OCaml bytecode linker (default \verb+$(OCAMLC)+). # \var{OCAMLOPTLINK} The OCaml native-code linker (default \verb+$(OCAMLOPT)+). # \var{OCAMLINCLUDES} Search path to pass to the OCaml compilers (default \verb+.+). # The search path with the \verb+-I+ prefix is defined by the \verb+PREFIXED_OCAMLINCLUDES+ # variable. # \varlabel{OCAMLINCLUDES_FOR_OCAMLDEP_MODULES}{OCAMLINCLUDES\_FOR\_OCAMLDEP\_MODULES} Extra path for searching files # corresponding to dependencies returned by "ocamldep -modules". This # defaults to ".". There is normally no reason to change this value. # \var{OCAMLFIND} The \verb+ocamlfind+ utility (default \verb+ocamlfind+ if # \verb+USE_OCAMLFIND+ is set, otherwise empty). # \var{OCAMLFINDFLAGS} The flags to pass to \verb+ocamlfind+ (default empty, \verb+USE_OCAMLFIND+ must be set). # \var{OCAMLPACKS} Package names to pass to \verb+ocamlfind+ (\verb+USE_OCAMLFIND+ must be set). # \varlabel{BYTE_ENABLED}{BYTE\_ENABLED} Flag indicating whether to use the bytecode compiler (default \verb+true+, when no \verb+ocamlopt+ found, \verb+false+ otherwise). # \varlabel{NATIVE_ENABLED}{NATIVE\_ENABLED} Flag indicating whether to use the native-code compiler (default \verb+true+, when ocamlopt is found, \verb+false+ otherwise). # Both \verb+BYTE_ENABLED+ and \verb+NATIVE_ENABLED+ can be set to true; # at least one should be set to true. # \varlabel{CMXS_ENABLED}{CMXS\_ENABLED} Flag indicating whether libraries are # also created as plugins. This defaults to \verb+false+ for compatibility # with old omake versions. Set it to \verb+CMXS_SUPPORTED+ to enable this # feature when supported # \varlabel{MENHIR_ENABLED}{MENHIR\_ENABLED} Define this as \verb+true+ if you wish to use # \verb+menhir+ instead of \verb+ocamlyacc+ (default \verb+false+). # \varlabel{EXTENDED_DIGESTS}{EXTENDED\_DIGESTS} Whether to include more information into # rule digests and make it more sensitive to structural changes at the cost # of build speed (\verb+true+ or \verb+false+). # \varlabel{OCAML_CC}{OCAML\_CC} The C compiler used internally by OCaml # \varlabel{OCAML_CFLAGS}{OCAML\_CFLAGS} The C compiler flags used by OCaml # \end{doc} # public.USE_OCAMLFIND = false private.get_c_comp() = # since OCaml-4.06 private.config = $(concat $(unhexify 0a), $(shella ocamlc -config))) private.configch = $(open-in-string $(config)) scan($(configch)) case $"c_compiler:" return $(nth-tl 1, $*) return $(string) private.get_bytecomp_cflags() = # since OCaml-4.06 private.config = $(concat $(unhexify 0a), $(shella ocamlc -config))) private.configch = $(open-in-string $(config)) scan($(configch)) case $"ocamlc_cflags:" return $(nth-tl 1, $*) return $(string) private.get_bytecomp_cppflags() = # since OCaml-4.06 private.config = $(concat $(unhexify 0a), $(shella ocamlc -config))) private.configch = $(open-in-string $(config)) scan($(configch)) case $"ocamlc_cppflags:" return $(nth-tl 1, $*) return $(string) private.get_bytecomp_c_comp() = private.config = $(concat $(unhexify 0a), $(shella ocamlc -config))) private.configch = $(open-in-string $(config)) scan($(configch)) case $"bytecomp_c_compiler:" return $(nth-tl 1, $*) return $(string) .STATIC: :value: $(PATH) OCAMLFIND_EXISTS = $(CheckProg ocamlfind) OCAMLC_OPT_EXISTS = $(CheckProg ocamlc.opt) OCAMLC_EXISTS = $(or $(OCAMLC_OPT_EXISTS), $(CheckProg ocamlc)) OCAMLOPT_OPT_EXISTS = $(CheckProg ocamlopt.opt) OCAMLOPT_EXISTS = $(or $(OCAMLOPT_OPT_EXISTS), $(CheckProg ocamlopt)) OCAMLDEP_OPT_EXISTS = $(CheckProg ocamldep.opt) OCAMLLEX_OPT_EXISTS = $(CheckProg ocamllex.opt) ConfMsgChecking(whether ocamlc understands the "z" warnings) OCAML_ACCEPTS_Z_WARNING = if $(OCAMLC_EXISTS) value $(ConfMsgYesNo $(shell-success-null ocamlc$(if $(OCAMLC_OPT_EXISTS), .opt) -w Az)) else ConfMsgResult($"FAILED - ocamlc not found") value false ConfMsgChecking(whether ocamlopt can create cmxs plugins) CMXS_SUPPORTED = if $(OCAMLOPT_EXISTS) ok = $(ConfMsgYesNo $(shell-success-null ocamlopt -shared -o .dummy.cmxs)) rm(-f .dummy.cmxs) value $(ok) else ConfMsgResult($"no (ocamlopt not found)") value false # # Compile native or byte code? # NATIVE_ENABLED = $(OCAMLOPT_EXISTS) BYTE_ENABLED = $(not $(OCAMLOPT_EXISTS)) CMXS_ENABLED = false # EXTENDED_DIGESTS = false # # Figure out the params for the C compiler # private.c_comp = $(get_c_comp) if $(equal X$(c_comp)X, XX) private.bytecomp_c_comp = $(get_bytecomp_c_comp) OCAML_CC = $(nth-hd 1, $(bytecomp_c_comp)) OCAML_CFLAGS = $(nth-tl 1, $(bytecomp_c_comp)) export OCAML_CC OCAML_CFLAGS else private.bytecomp_cflags = $(get_bytecomp_cflags) private.bytecomp_cppflags = $(get_bytecomp_cppflags) OCAML_CC = $(c_comp) OCAML_CFLAGS = $(bytecomp_cflags) $(bytecomp_cppflags) export OCAML_CC OCAML_CFLAGS public.OCAMLFIND = $`(if $(USE_OCAMLFIND), ocamlfind) public.OCAMLFINDFLAGS = public.LAZY_OCAMLFINDFLAGS = $`(if $(USE_OCAMLFIND), $(OCAMLFINDFLAGS)) # OCAMLC/OCAMLOPT/OCAMLDEP are now 0-ary functions instead of normal variables # because sometimes USE_OCAMLFIND is set too late by the user. public.OCAMLC() = value $(if $(OCAMLC_OPT_EXISTS), $(if $(USE_OCAMLFIND), ocamlc, ocamlc.opt), ocamlc) public.OCAMLOPT() = value $(if $(OCAMLOPT_OPT_EXISTS), $(if $(USE_OCAMLFIND), ocamlopt, ocamlopt.opt), ocamlopt) public.OCAMLDEP() = value $(if $(OCAMLDEP_OPT_EXISTS), $(if $(USE_OCAMLFIND), ocamldep, ocamldep.opt), ocamldep) public.CAMLP4 = camlp4 public.OCAMLLEX = $(if $(OCAMLLEX_OPT_EXISTS), ocamllex.opt, ocamllex) public.OCAMLLEXFLAGS = -q public.OCAMLYACC = ocamlyacc public.OCAMLYACCFLAGS = public.OCAMLMKTOP = ocamlmktop public.OCAMLLINK = $`(OCAMLC) public.OCAMLOPTLINK = $`(OCAMLOPT) .STATIC: :value: $(PATH) OCAMLLIB = if $(OCAMLC_EXISTS) ConfMsgChecking(for OCaml library location) value $(ConfMsgResult $(dir $"$(shell ocamlc -where)")) else value $(EMPTY) # # Include path # public.OCAMLINCLUDES[] = . public.OCAMLINCLUDES_FOR_OCAMLDEP_MODULES[] = . public.PREFIXED_OCAMLINCLUDES = $`(mapprefix -I, $(OCAMLINCLUDES)) # # Packages # public.OCAMLPACKS[] = public.PREFIXED_OCAMLPACKS =\ $`(if $(and $(USE_OCAMLFIND) $(gt $(length $(OCAMLPACKS)), 0)),\ -package $(string $(concat \,, $(OCAMLPACKS))),\ $(EMPTY)) # # Various options # # \begin{doc} # \subsection{OCaml command flags} # # The following variables specify \emph{additional} options to be passed to # the OCaml tools. # \var{OCAMLDEPFLAGS} Flags to pass to \verb+OCAMLDEP+. # \var{OCAMLPPFLAGS} Flags to pass to \verb+CAMLP4+. # \var{OCAMLCFLAGS} Flags to pass to the byte-code compiler (default \verb+-g+). # \var{OCAMLOPTFLAGS} Flags to pass to the native-code compiler (default empty). # \var{OCAMLFLAGS} Flags to pass to either compiler (default \verb+-warn-error A+). # \varlabel{OCAML_BYTE_LINK_FLAGS}{OCAML\_BYTE\_LINK\_FLAGS} Flags to pass to the byte-code linker (default empty). # \varlabel{OCAML_NATIVE_LINK_FLAGS}{OCAML\_NATIVE\_LINK\_FLAGS} Flags to pass to the native-code linker (default empty). # \varlabel{OCAML_LINK_FLAGS}{OCAML\_LINK\_FLAGS} Flags to pass to either linker. # \varlabel{MENHIR_FLAGS}{MENHIR\_FLAGS} Additional flags to pass to \verb+menhir+. # \end{doc} # declare OCAMLDEPFLAGS public.OCAMLPPFLAGS = public.OCAMLFLAGS = public.OCAMLCFLAGS = -g public.OCAMLOPTFLAGS = public.OCAMLCPPFLAGS = public.OCAML_LINK_FLAGS = $`(if $(and $(USE_OCAMLFIND) $(gt $(length $(OCAMLPACKS)), 0)), -linkpkg, $(EMPTY)) public.OCAML_BYTE_LINK_FLAGS = -custom public.OCAML_NATIVE_LINK_FLAGS = # # OCAML_LIBS contains libraries that are used as dependencies # OCAML_OTHER_LIBS contains other libraries (like unix.cma) # The lists do not include suffixes. # # OCAML_LINK_FLAGS contains extra linking information # # \begin{doc} # \subsection{Library variables} # # The following variables are used during linking. # # \varlabel{OCAML_LIBS}{OCAML\_LIBS} Libraries to pass to the linker. These libraries become dependencies # of the link step. # \varlabel{OCAML_OTHER_LIBS}{OCAML\_OTHER\_LIBS} Additional libraries to pass to the linker. These libraries are # \emph{not} included as dependencies to the link step. Typical use is for the OCaml # standard libraries like \verb+unix+ or \verb+str+. # \varlabel{OCAML_CLIBS}{OCAML\_CLIBS} C libraries to pass to the linker. # \varlabel{OCAML_LIB_FLAGS}{OCAML\_LIB\_FLAGS} Extra flags for the library linker. # \varlabel{ABORT_ON_DEPENDENCY_ERRORS}{ABORT\_ON\_DEPENDENCY\_ERRORS} # OCaml linker requires the OCaml files to be # listed in dependency order. Normally, all the functions presented in this section will automatically sort # the list of OCaml modules passed in as the \verb++ argument. However, this variable is # set to \verb+true+, the order of the files passed into these function will be left as is, but \OMake{} will # abort with an error message if the order is illegal. # # \end{doc} # public.OCAML_LIBS = public.OCAML_CLIBS = public.OCAML_OTHER_LIBS = public.OCAML_LIB_FLAGS = ######################################################################## # \begin{doc} # \subsection{Generated OCaml Files} # \label{section:ocaml-generated-files} # As of OCaml version 3.09.2, the standard \verb+ocamldep+ scanner is ``broken''. The main issue is # that it finds only those dependencies that already exist. If \verb+foo.ml+ contains a dependency # on \verb+Bar+, # \begin{verbatim} # foo.ml: # open Bar # \end{verbatim} # then the default \verb+ocamldep+ will only find the dependency if a file \verb+bar.ml+ or # \verb+bar.ml+ exists in the include path. It will not find (or print) the dependency if, for # example, only \verb+bar.mly+ exists at the time \verb+ocamldep+ is run, even though \verb+bar.ml+ # and \verb+bar.mli+ can be generated from \verb+bar.mly+. # # \OMake{} currently provides two methods for addressing this problem --- one that requires manually # specifying the generated files, and an experimental method for discovering such ``hidden'' # dependencies automatically. The # \hypervarx{OCAMLDEP_MODULES_ENABLED}{OCAMLDEP\_MODULES\_ENABLED} controls which method is # going to be used. When this variable is false, the manual specifications are expected and when it # is true, the automated discovery will be attempted. # # \twofuns{OCamlGeneratedFiles}{LocalOCamlGeneratedFiles} # \begin{verbatim} # OCamlGeneratedFiles(files) # LocalOCamlGeneratedFiles(files) # \end{verbatim} # # When the \hypervarx{OCAMLDEP_MODULES_ENABLED}{OCAMLDEP\_MODULES\_ENABLED} variable is set # to \verb+false+, the \verb+OCamlGeneratedFiles+ and \verb+LocalOCamlGeneratedFiles+ functions specify files # that need to be generated before any OCaml files are scanned for dependencies. For example, # if \verb+parser.ml+ and \verb+lexer.ml+ are both generated files, specify: # \begin{verbatim} # OCamlGeneratedFiles(parser.ml lexer.ml) # \end{verbatim} # # The \verb+OCamlGeneratedFiles+ function is \emph{global} --- its arguments will be generated # before any OCaml files anywhere in the project are scanned for dependencies. The # \verb+LocalOCamlGeneratedFiles+ function follows the normal scoping rules of OMake. # # These functions have no effect when the # \hypervarx{OCAMLDEP_MODULES_ENABLED}{OCAMLDEP\_MODULES\_ENABLED} is true. # # \subsubsection{Automatic discovery of generated files during dependency analysis} # Having to specify the generated files manualy when \OMake{} could discover them automatically is # obviously suboptimal. To address this, we tell \verb+ocamldep+ to \emph{only} # find the free module names in a file and then post-process the results internally. # # This automated functionality is enabled when the # \hypervarx{OCAMLDEP_MODULES_ENABLED}{OCAMLDEP\_MODULES\_ENABLED} is set to \verb+true+. # By default, \hypervarx{OCAMLDEP_MODULES_ENABLED}{OCAMLDEP\_MODULES\_ENABLED} will be set to # \verb+$(OCAMLDEP_MODULES_AVAILABLE)+. # # Note that the \verb+ocamldep+ functionality this relies upon is only included in # the OCaml version 3.10 and higher. It's availability will be discovered automatically # and the \hypervarx{OCAMLDEP_MODULES_AVAILABLE}{OCAMLDEP\_MODULES\_AVAILABLE} # will be set accordingly. # # \end{doc} # .STATIC: ConfMsgChecking(if ocamldep understands -modules) OCAMLDEP_MODULES_AVAILABLE = $(ConfMsgYesNo $(shell-success-null ocamldep -modules)) public.OCAMLDEP_MODULES_ENABLED = $(OCAMLDEP_MODULES_AVAILABLE) public.OCAMLDEPFLAGS = $`(if $(and $(NATIVE_ENABLED), $(not $(OCAMLDEP_MODULES_ENABLED))), -native, $(EMPTY)) .PHONY: OCamlGeneratedFilesTarget # GS: The test on $(OCAMLDEP_MODULES_ENABLED) in only partially working. # What if we set this variable later? public.OCamlGeneratedFiles(files) = if $(OCAMLDEP_MODULES_ENABLED) # For now, we want to allow ``backwards-compatible'' projects. # eprintln($"WARNING: OCamlGeneratedFiles should not be used when OCAMLDEP_MODULES_ENABLED") # eprintln($" is set") else OCamlGeneratedFilesTarget: $(files) public.LocalOCamlGeneratedFiles(files) = if $(OCAMLDEP_MODULES_ENABLED) # For now, we want to allow ``backwards-compatible'' projects. # eprintln($"WARNING: OCamlGeneratedFiles should not be used when OCAMLDEP_MODULES_ENABLED") # eprintln($" is set") else .SCANNER: scan-ocaml-%: $(files) .SCANNER: %.cmi: $(files) .SCANNER: %.cmx %.cmo: $(files) export export # # The ocamldep -modules output has the following # form, where the indented lines are the free module names in foo.ml. # # foo.ml: # Bar # ... # # From this, we generate proper dependencies by finding the files # that can be built, using the find-targets-in-path-optional # function. # # # Print the dependencies for a ML file, based on the # .cmi files. # # If OCAMLDEP_PRESERVE_TARGETS is true, then the # ocamldep entries are taken literally (the suffix # is not replaced with .cmo/.cmx). # public.OCAMLDEP_PRESERVE_TARGETS = false public.PrintMLIDependencies(filename, cmideps) = if $(cmideps) private.base = $(string-escaped $(removesuffix $(filename))) println($"""$(base).cmi: $(string-escaped $(cmideps))""") public.PrintMLDependencies(filename, cmideps, cmxdeps) = protected.base = $(string-escaped $(removesuffix $(filename))) protected.esc = $' \' protected.text = if $(cmideps) cmideps = $(string-escaped $(cmideps)) text = $""" $(base).cmo: $(cmideps) $(base).cmx $(base)$(EXT_OBJ):$(esc) $(cmideps)""" export text if $(cmxdeps) if $(not $(text)) text = $"""$(base).cmx $(base)$(EXT_OBJ):""" export text += $"""$(esc) $(string-escaped $(cmxdeps))""" export text # eprintln($(text)) println($(text)) public.PrintFileDependencies(filename, cmideps) = if $(cmideps) private.text = $"""$(string-escaped $(filename)): $(string-escaped $(cmideps))""" # eprintln($(text)) println($(text)) # # Given a set of literal dependencies, compute # the actual dependencies by finding the filenames # associated with each module. # public.PrintDependencies(filename, modules) = private.includes[] = $(OCAMLINCLUDES_FOR_OCAMLDEP_MODULES) $(OCAMLINCLUDES) if $(filename) # # Find the .cmi files that can be built # private.cmideps = $(find-ocaml-targets-in-path-optional $(includes), $(addsuffix .cmi, $(modules))) # Now produce the dependencies if $(OCAMLDEP_PRESERVE_TARGETS) PrintFileDependencies($(filename), $(cmideps)) else switch($(suffix $(filename))) case .ml protected.cmxdeps[] = if $(NATIVE_ENABLED) cmxdeps = $(find-ocaml-targets-in-path-optional $(includes), $(addsuffix .cmx, $(modules))) export PrintMLDependencies($(filename), $(cmideps), $(cmxdeps)) case .mli PrintMLIDependencies($(filename), $(cmideps)) default eprintln($"ocaml scanner: illegal filename $(filename)") exit(1) # # Post-process the output of ocamldep. # Use awk to process the input, find the targets that # exist, and then print the dependencies. # public.OCamlScannerPostproc(input) = # # Read the module names from the standard input # protected.filename = protected.modules[] = awk(b, $(input)) case $'^\(.*\):[[:space:]]*\(.*\)$' PrintDependencies($(filename), $(modules)) filename = $1 modules[] = $(split $' ', $2) export case $'^ \(.*\)' # Add the dependency modules[] += $1 export default eprintln(Unrecognized ocamldep output: $0) PrintDependencies($(filename), $(modules)) Shell. += ocamldep-postproc(argv) = if $(defined ocamldep-postproc) ocamldep-postproc($(OCAMLINCLUDES_FOR_OCAMLDEP_MODULES) $(OCAMLINCLUDES), $(NATIVE_ENABLED)) else OCamlScannerPostproc($(stdin)) Shell. += ocamldep-postproc-preserve(argv) = OCAMLDEP_PRESERVE_TARGETS = true OCamlScannerPostproc($(stdin)) public.OCamlScanner(src_file) = if $(OCAMLDEP_MODULES_ENABLED) value $(OCAMLFIND) $(OCAMLDEP) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLDEPFLAGS) -modules $(src_file) | ocamldep-postproc else value $(OCAMLFIND) $(OCAMLDEP) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLDEPFLAGS) $(PREFIXED_OCAMLINCLUDES) $(src_file) ######################################################################## # Generic build rules. # # The order of the %.cmi rules is important. # The most recent definition is used first, if it applies. # 1. The .cmi is generated from the .mli, if it exists # 2. Otherwise it is generated from the .ml # # In case 2, make sure to use the same command text that is used for # generating the .cmo or .cmx file. This will prevent the compiler # from being called twice: once to generate the .cmi file, and again # for the .cmo or .cmx file. # public.OCamlC() = value $(OCAMLFIND) $(OCAMLC) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS)\ $(OCAMLCFLAGS) $(OCAMLPPFLAGS) $(PREFIXED_OCAMLINCLUDES) public.OCamlOpt() = value $(OCAMLFIND) $(OCAMLOPT) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS)\ $(OCAMLOPTFLAGS) $(OCAMLPPFLAGS) $(PREFIXED_OCAMLINCLUDES) %.cmx: %.ml section rule if $(not $(NATIVE_ENABLED)) err. = extends $(UnbuildableException) message = $(string $"You are trying to build OCaml native code file: "%.cmx$" However, the NATIVE_ENABLED flag is not set. Include the following definition in your OMakefile if you really want to build this file. NATIVE_ENABLED = true") target = $(file %.cmx) raise $(err) elseif $(target-exists %.mli) %.cmx %$(EXT_OBJ): %.ml %.cmi :scanner: scan-ocaml-%.ml $(OCamlOpt) -c $< elseif $(BYTE_ENABLED) %.cmx %.cmi %$(EXT_OBJ) %.cmo: %.ml :scanner: scan-ocaml-%.ml $(OCamlC) -c $< $(OCamlOpt) -c $< else %.cmx %.cmi %$(EXT_OBJ): %.ml :scanner: scan-ocaml-%.ml $(OCamlOpt) -c $< %$(EXT_OBJ): %.ml section rule if $(not $(NATIVE_ENABLED)) err. = extends $(UnbuildableException) message = $(string $"You are trying to build OCaml native code file: "%$(EXT_OBJ)$" However, the NATIVE_ENABLED flag is not set. Include the following definition in your OMakefile if you really want to build this file. NATIVE_ENABLED = true") target = $(file %.cmx) raise $(err) elseif $(target-exists %.mli) %$(EXT_OBJ) %.cmx: %.ml %.cmi :scanner: scan-ocaml-%.ml $(OCamlOpt) -c $< elseif $(BYTE_ENABLED) %$(EXT_OBJ) %.cmi %.cmx %.cmo: %.ml :scanner: scan-ocaml-%.ml $(OCamlC) -c $< $(OCamlOpt) -c $< else %$(EXT_OBJ) %.cmi %.cmx: %.ml :scanner: scan-ocaml-%.ml $(OCamlOpt) -c $< # This is an experimental rule %.i.mli: %.ml section rule %.i.mli: %.ml %.cmi :scanner: scan-ocaml-%.ml $(OCamlC) -i -c %.ml > $@ %.cmo: %.ml section rule if $(not $(BYTE_ENABLED)) err. = extends $(UnbuildableException) message = $(string $"You are trying to build OCaml native code file: "%.cmo$" However, the BYTE_ENABLED flag is not set. Include the following definition in your OMakefile if you really want to build this file. BYTE_ENABLED = true") target = $(file %.cmx) raise $(err) elseif $(target-exists %.mli) %.cmo: %.ml %.cmi :scanner: scan-ocaml-%.ml $(OCamlC) -c $< elseif $(NATIVE_ENABLED) %.cmo %.cmi %.cmx %$(EXT_OBJ): %.ml :scanner: scan-ocaml-%.ml $(OCamlC) -c $< $(OCamlOpt) -c $< else %.cmo %.cmi: %.ml :scanner: scan-ocaml-%.ml $(OCamlC) -c $< %.cmi: %.ml section rule if $(BYTE_ENABLED) if $(NATIVE_ENABLED) %.cmi %.cmo %.cmx %$(EXT_OBJ): %.ml :scanner: scan-ocaml-%.ml $(OCamlC) -c $< $(OCamlOpt) -c $< else %.cmi %.cmo: %.ml :scanner: scan-ocaml-%.ml $(OCamlC) -c $< else %.cmi %.cmx %$(EXT_OBJ): %.ml :scanner: scan-ocaml-%.ml $(OCamlOpt) -c $< %.cmi: %.mli :scanner: scan-ocaml-%.mli $(OCamlC) -c $< # \begin{doc} # \fun{DeclareMLIOnly} # # Sometimes, MLI files only contain type and exception definitions. In fact, # the MLI file could also be parsed as ML file. For convenience, it is possible # to declare modules as MLI-only. In this case, an ML file needs not to be # written. Do this as follows: # # \verb+DeclareMLIOnly()+ # # where the \verb++ are without suffixes. # # Note that this really only works if the MLI file can be parsed as ML file. # Also, it is possible this results in an object to be linked in, so don't # forget to link the modules into the library or executable. # \end{doc} DeclareMLIOnly(modules) = foreach(mod => ..., $(modules)) if $(BYTE_ENABLED) if $(NATIVE_ENABLED) $(mod).cmi $(mod).cmo $(mod).cmx $(mod).o: $(mod).mli $(OCamlC) -c $(mod).mli $(OCamlC) -c -impl $(mod).mli $(OCamlOpt) -c -impl $(mod).mli else $(mod).cmi $(mod).cmo: $(mod).mli $(OCamlC) -c $(mod).mli $(OCamlC) -c -impl $(mod).mli else $(mod).cmi $(mod).cmx $(mod).o: $(mod).mli $(OCamlC) -c $(mod).mli $(OCamlOpt) -c -impl $(mod).mli ######################################################################## # Parser generators # # # You can choose to use ocamlyacc or menhir for a parser # generator. The default is ocamlyacc. Define the # MENHIR_ENABLED as true if you would rather use menhir. # # Variables: # MENHIR : the name of the menhir executable # MENHIR_FLAGS : any additional options to pass to Menhir # MENHIR_AVAILABLE : the menhir executable is installed # MENHIR_RAW_DEPEND : menhir supports the --raw-depend option # public.MENHIR = menhir public.MENHIR_FLAGS = public.MENHIR_ENABLED = false .STATIC: MENHIR_AVAILABLE = $(CheckProg $(MENHIR)) MENHIR_RAW_DEPEND = false if $(MENHIR_AVAILABLE) ConfMsgChecking(if $(MENHIR) supports the --raw-depend option) MENHIR_RAW_DEPEND = $(ConfMsgYesNo $(shell-success-null $(MENHIR) -help | grep $'^ *--raw-depend')) export # Menhir is being requested. Check that it is installed. public.MenhirCheck() = if $(not $(MENHIR_AVAILABLE)) eprintln($"""!!! You are asking to use Menhir, but it is not installed.""") eprintln($"""!!! See the Menhir home page for instructions on downloading.""") eprintln($"""!!! http://cristal.inria.fr/~fpottier/menhir/""") exit(1) # Compute the correct ocamlc and ocamldep options for Menhir. public.MenhirOCamlcCommand() = MenhirCheck() private.ocamlc[] =\ $(OCAMLFIND) $(OCAMLC) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS)\ $(OCAMLCFLAGS) $(OCAMLPPFLAGS) $(PREFIXED_OCAMLINCLUDES) value --ocamlc $(quote-argv $(ocamlc)) public.MenhirOCamldepCommand(raw) = ocamldep = if $(raw) value $(OCAMLDEP) -modules $(OCAMLDEPFLAGS) else value $(OCAMLDEP) $(PREFIXED_OCAMLINCLUDES) $(OCAMLDEPFLAGS) value --ocamldep $(quote-argv $(ocamldep)) # Compute the Mendir dependency scanner command public.MenhirScannerCommand(base, src) = if $(MENHIR_ENABLED) if $(and $(MENHIR_RAW_DEPEND), $(OCAMLDEP_MODULES_ENABLED)) value $(MENHIR) $(MENHIR_FLAGS) $(MenhirOCamldepCommand true) $(base) --raw-depend $(src) | ocamldep-postproc-preserve else value $(MENHIR) $(MENHIR_FLAGS) $(MenhirOCamldepCommand false) $(base) --depend $(src) # Use Menhir if MENHIR_ENABLED, ocamlyacc otherwise public.OCamlYaccCommand(src) = if $(MENHIR_ENABLED) value $(MENHIR) $(MENHIR_FLAGS) $(MenhirOCamlcCommand) $(src) else value $(OCAMLYACC) $(OCAMLYACCFLAGS) $(src) .SCANNER: scan-ocamlyacc-%.mly: %.mly :value: $(MENHIR_ENABLED) $(OCamlScannerTargets $&) $(MenhirScannerCommand $(EMPTY), $<) %.ml %.mli: %.mly :scanner: scan-ocamlyacc-%.mly $(OCamlYaccCommand $<) # # \begin{doc} # \subsection{Using the Menhir parser generator} # # Menhir is a parser generator that is mostly compatible with # \verb+ocamlyacc+, but with many improvements. A few of these # are listed here (excerpted from the Menhir home page # \url{http://cristal.inria.fr/~fpottier/menhir/}). # # \begin{itemize} # \item Menhir's explanations are believed to be understandable by mere humans. # \item Menhir allows grammar specifications to be split over multiple files. # It also allows several grammars to share a single set of tokens. # \item Menhir is able to produce parsers that are parameterized by Objective Caml modules. # \item [Added by jyh] With the \verb+--infer+ option, Menhir can typecheck the semantic actions # in your grammar at \emph{generation} time. # \end{itemize} # # What do you need to do to use Menhir instead of \verb+ocamlyacc+? # \begin{enumerate} # \item Place the following definition before the relevant section of your project # (or at the top of your project \verb+OMakefile+ if you want to use Menhir everywhere). # # \begin{verbatim} # MENHIR_ENABLED = true # \end{verbatim} # # \item Optionally, add any desired Menhir options to the \verb+MENHIR_FLAGS+ variable. # # \begin{verbatim} # MENHIR_FLAGS += --infer # \end{verbatim} # \end{enumerate} # # With this setup, any file with a \verb+.mly+ suffix will be compiled with Menhir. # # If your grammar is split across several files, you need to specify it explicitly, # using the \verb+MenhirMulti+ function. # # \begin{verbatim} # MenhirMulti(target, sources) # target : filename, without suffix # sources : the files that define the grammar, without suffixes # \end{verbatim} # # For example, if you want to generate the parser files \verb+parse.ml+ and \verb+parse.mli+, # from the grammar specified in files \verb+a.mly+ and \verb+b.mly+, you would use # the following. # # \begin{verbatim} # MenhirMulti(parse, a b) # \end{verbatim} # \end{doc} # public.MenhirMulti(target, sources) = MenhirCheck() sources = $(addsuffix .mly, $(sources)) # Menhir needs all the files for dependency analysis .SCANNER: scan-menhir-$(target).multi: $(sources) :value: $(OCamlScannerTargets $&) $(MenhirScannerCommand --base $(target), $+) # Set up the actual rule $(target).ml $(target).mli: $(sources) :scanner: scan-menhir-$(target).multi $(MENHIR) $(MENHIR_FLAGS) $(MenhirOCamlcCommand) --base $(target) $+ ######################################################################## # Other common generated files # %.ml %.mli: %.mlz ln-or-cp $< $*.ml ln-or-cp $< $*.mli %.ml: %.mll $(OCAMLLEX) $(OCAMLLEXFLAGS) $< %.ml: %.mlp %.h @rm -f $@ @echo "(* CAUTION: this is a generated file. If you edit it, all changes will be lost! *)" > $@ $(CPP) $(OCAMLCPPFLAGS) -imacros $*.h $*.mlp >> $@ @chmod 444 $@ # # Generic scanners # OCamlScannerTargetsExtended(files) = files[] = $(basename $(files)) files[] = $(if $(NATIVE_ENABLED), $(files), $(filter-out %.cmx, $(files))) files[] = $(if $(BYTE_ENABLED), $(files), $(filter-out %.cmo, $(files))) value $(find-targets-in-path-optional $(OCAMLINCLUDES), $(files)) $(NATIVE_ENABLED) $(BYTE_ENABLED) OCamlScannerTargetsSimplified(dummy) = value $(NATIVE_ENABLED) $(BYTE_ENABLED) if $(EXTENDED_DIGESTS) OCamlScannerTargets = $(OCamlScannerTargetsExtended) export else OCamlScannerTargets = $(OCamlScannerTargetsSimplified) export .SCANNER: scan-ocaml-%.mli: %.mli /.PHONY/OCamlGeneratedFilesTarget :value: $(OCamlScannerTargets $&) $(OCamlScanner $<) .SCANNER: scan-ocaml-%.ml: %.ml /.PHONY/OCamlGeneratedFilesTarget :exists: %.mli :value: $(OCamlScannerTargets $&) $(OCamlScanner $<) # # Default .SCANNER rules for backwards-compatibility. # .SCANNER: %.cmi: %.mli /.PHONY/OCamlGeneratedFilesTarget :value: $(OCamlScannerTargets $&) $(OCamlScanner $<) .SCANNER: %.cmx %.cmo %$(EXT_OBJ): %.ml /.PHONY/OCamlGeneratedFilesTarget :exists: %.mli :value: $(OCamlScannerTargets $&) $(OCamlScanner $<) # # Define a link order for OCaml files. # If a file depends on a %.cmi, it also depends on %.cmo # .ORDER: .OCAMLLINK .OCAMLLINK: %.cmi: %.cmo .OCAMLLINK: %.cmx: %.cmo public.ABORT_ON_DEPENDENCY_ERRORS = false OCamlLinkSort(nodes) = if $(ABORT_ON_DEPENDENCY_ERRORS) value $(file-check-sort .OCAMLLINK, $(nodes)) else value $(file-sort .OCAMLLINK, $(nodes)) # # Generic rule to build an ML library # # \begin{doc} # \fun{OCamlLibrary} # # The \verb+OCamlLibrary+ function builds an OCaml library. # # \verb+OCamlLibrary(, )+ # # The \verb++ and \verb++ are listed \emph{without} suffixes. # # This function returns the list of all the targets that it defines the rules # for (including the \verb+$(name)$(EXT_LIB)+ file when \verb+NATIVE_ENABLED+ is set). # # The following code builds the \verb+libfoo.cmxa+ library from the files \verb+foo.cmx+ # and \verb+bar.cmx+ (if \verb+NATIVE_ENABLED+ is set), and \verb+libfoo.cma+ from # \verb+foo.cmo+ and \verb+bar.cmo+ (if \verb+BYTE_ENABLED+ is set). # # \begin{verbatim} # OCamlLibrary(libfoo, foo bar) # \end{verbatim} # # If the variable \verb+CMXS_ENABLED+ is set, additionally the cmxs plugin # is created. Note that \verb+CMXS_SUPPORTED+ returns whether the compiler # installation supports plugins, so you can simply set # # \begin{verbatim} # CMXS_ENABLED = CMXS_SUPPORTED # \end{verbatime} # # before calling \verb+OCamlLibrary+. For compatibility with older omake # versions, \verb+CMXS_ENABLED+ defaults to \verb+false+. # \end{doc} # public.OCamlLibrary(name, files) = # XXX: JYH: these variables should be marked private in 0.9.9 protected.name = $(file $(name)) protected.OFILES = $(addsuffix $(EXT_OBJ), $(files)) protected.CMOFILES = $(addsuffix .cmo, $(files)) protected.CMXFILES = $(addsuffix .cmx, $(files)) protected.CLIB = $(file $(name)$(EXT_LIB)) protected.BYTELIB = $(file $(name).cma) protected.NATIVELIB = $(file $(name).cmxa) protected.SHAREDLIB = $(file $(name).cmxs) # # Link commands # $(BYTELIB): $(CMOFILES) $(OCAMLFIND) $(OCAMLLINK) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) $(OCAMLCFLAGS) \ $(OCAML_LIB_FLAGS) -a -o $@ $(OCamlLinkSort $(CMOFILES)) $(NATIVELIB) $(CLIB): $(CMXFILES) $(OFILES) $(OCAMLFIND) $(OCAMLOPTLINK) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ $(OCAML_LIB_FLAGS) -a -o $(NATIVELIB) $(OCamlLinkSort $(CMXFILES)) $(SHAREDLIB): $(NATIVELIB) $(CLIB) $(OCAMLFIND) $(OCAMLOPTLINK) -shared -cclib -L. -o $(SHAREDLIB) $(NATIVELIB) return $(array $(if $(NATIVE_ENABLED), $(NATIVELIB)), $(if $(NATIVE_ENABLED), $(CLIB)), $(if $(BYTE_ENABLED), $(BYTELIB)), $(if $(CMXS_ENABLED), $(SHAREDLIB))) # # Generic rule to build an ML library # # \begin{doc} # \fun{OCamlPackage} # # The \verb+OCamlPackage+ function builds an OCaml package. # # \verb+OCamlPackage(, )+ # # The \verb++ and \verb++ are listed \emph{without} suffixes. # The \verb++ must have been compiled with the \verb+-for-pack + # flag to the OCaml compiler. # # This function returns the list of all the targets that it defines the rules # for (including the \verb+$(name)$(EXT_LIB)+ file when \verb+NATIVE_ENABLED+ is set). # # The following code builds the \verb+libfoo.cmx+ package from the files \verb+package.cmx+ # and \verb+bar.cmx+ (if \verb+NATIVE_ENABLED+ is set), and \verb+package.cmo+ from # \verb+foo.cmo+ and \verb+bar.cmo+ (if \verb+BYTE_ENABLED+ is set). # # \begin{verbatim} # OCamlPackage(package, foo bar) # \end{verbatim} # \end{doc} # public.OCamlPackage(name, files) = # XXX: JYH: these variables should be marked private in 0.9.9 protected.OFILES = $(addsuffix $(EXT_OBJ), $(files)) protected.CMOFILES = $(addsuffix .cmo, $(files)) protected.CMXFILES = $(addsuffix .cmx, $(files)) protected.OBJ = $(file $(name)$(EXT_OBJ)) protected.CMO = $(file $(name).cmo) protected.CMX = $(file $(name).cmx) protected.CMI = $(file $(name).cmi) protected.MLI = $(file $(name).mli) protected.BYTE_TARGETS = $(CMO) protected.NATIVE_TARGETS = $(CMX) $(OBJ) protected.BYTE_DEPS = $(CMOFILES) protected.NATIVE_DEPS = $(CMXFILES) $(OFILES) # note that always returning $(CMI) is slightly incorrect, but we cannot # do it better protected.TARGETS = $(CMI) if $(NATIVE_ENABLED) TARGETS += $(NATIVE_TARGETS) export if $(BYTE_ENABLED) TARGETS += $(BYTE_TARGETS) export BYTE_CMD = $(OCAMLFIND) $(OCAMLC) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) \ $(OCAMLCFLAGS) $(OCAML_LIB_FLAGS) -pack -o $(CMO) $`(OCamlLinkSort $(CMOFILES)) NATIVE_CMD = $(OCAMLFIND) $(OCAMLOPTLINK) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) \ $(OCAMLOPTFLAGS) $(OCAML_LIB_FLAGS) -pack -o $(CMX) $`(OCamlLinkSort $(CMXFILES)) # # Link commands # # NB. we use here section rules because we want to evaluate target-exists # first when the build has started, and not NOW. The target could be # defined later. if $(and $(BYTE_ENABLED), $(NATIVE_ENABLED)) $(BYTE_TARGETS): section rule if $(target-exists $(MLI)) $(BYTE_TARGETS): $(BYTE_DEPS) $(CMI) $(BYTE_CMD) else $(BYTE_TARGETS) $(CMI): $(BYTE_DEPS) $(BYTE_CMD) $(NATIVE_TARGETS): section rule if $(target-exists $(MLI)) $(NATIVE_TARGETS): $(NATIVE_DEPS) $(CMI) $(NATIVE_CMD) else $(NATIVE_TARGETS): $(NATIVE_DEPS) $(CMI) $(NATIVE_CMD) -intf-suffix .cmi $(CMI): section rule if $(target-exists $(MLI)) $(CMI): $(MLI) else $(BYTE_TARGETS) $(CMI): $(BYTE_DEPS) $(BYTE_CMD) elseif $(BYTE_ENABLED) $(BYTE_TARGETS): section rule if $(target-exists $(MLI)) $(BYTE_TARGETS): $(BYTE_DEPS) $(CMI) $(BYTE_CMD) else $(BYTE_TARGETS) $(CMI): $(BYTE_DEPS) $(BYTE_CMD) $(CMI): section rule if $(target-exists $(MLI)) $(CMI): $(MLI) else $(BYTE_TARGETS) $(CMI): $(BYTE_DEPS) $(BYTE_CMD) elseif $(NATIVE_ENABLED) $(NATIVE_TARGETS): section rule if $(target-exists $(MLI)) $(NATIVE_TARGETS): $(NATIVE_DEPS) $(CMI) $(NATIVE_CMD) else $(NATIVE_TARGETS) $(CMI): $(NATIVE_DEPS) $(NATIVE_CMD) $(CMI): section rule if $(target-exists $(MLI)) $(CMI): $(MLI) else $(NATIVE_TARGETS) $(CMI): $(NATIVE_DEPS) $(NATIVE_CMD) return $(TARGETS) # # If the interfaces are to be installed, # define this variable to be true. # public.INSTALL_INTERFACES = false # # Install the library # # \begin{doc} # \fun{OCamlLibraryCopy} # # The \verb+OCamlLibraryCopy+ function copies a library to an install location. # # \verb+OCamlLibraryCopy(, , , )+ # # The \verb++ specify additional interface files # to be copied if the \verb+INSTALL_INTERFACES+ variable is true. # \end{doc} # public.OCamlLibraryCopy(tag, lib, name, ifiles) = # # Copy interfaces # if $(INSTALL_INTERFACES) private.MLIFILES = $(filter-targets $(addsuffix .mli, $(ifiles))) private.CMIFILES = $(addsuffix .cmi, $(ifiles)) foreach(src => ..., $(MLIFILES) $(CMIFILES)) $(lib)/$(basename $(src)): $(src) $(lib) :scanner: $(NOSCANNER) ln-or-cp $< $@ # Add to the install tag $(tag): $(file $(addprefix $(lib)/, $(basename $(MLIFILES) $(CMIFILES)))) # # Also install libraries # private.CLIB = $(file $(name)$(EXT_LIB)) private.BYTELIB = $(file $(name).cma) private.NATIVELIB = $(file $(name).cmxa) private.LIBCLIB = $(file $(lib)/$(name)$(EXT_LIB)) private.LIBBYTE = $(file $(lib)/$(name).cma) private.LIBNATIVE = $(file $(lib)/$(name).cmxa) # # Link libraries into lib directory # $(LIBBYTE): $(BYTELIB) ln-or-cp $< $@ $(LIBNATIVE): $(NATIVELIB) ln-or-cp $< $@ $(LIBCLIB): $(CLIB) ln-or-cp $< $@ # # Add dependencies to the target tag # public.FILES[] = if $(BYTE_ENABLED) FILES[] += $(LIBBYTE) export if $(NATIVE_ENABLED) FILES[] += $(LIBNATIVE) $(LIBCLIB) export $(tag): $(FILES) return $(FILES) # # We often use them together # # \begin{doc} # \fun{OCamlLibraryInstall} # # The \verb+OCamlLibraryInstall+ function builds a library # and copies it to an install location in one step. # # \verb+OCamlLibraryInstall(, , , )+ # \end{doc} # public.OCamlLibraryInstall(tag, lib, name, files) = OCamlLibrary($(name), $(files)) return $(OCamlLibraryCopy $(tag), $(lib), $(name), $(files)) # # Generic rule to build an OCaml program # name: the name of the target, without a suffix # files: names of the object files, without suffixes # # Other variables: # OCAML_LIBS: OCaml libraries target depends on, without suffix # OCAML_CLIBS: C libraries we depend on, without suffix # OCAML_OTHER_LIBS: OCaml libraries, without dependencies, without suffix # OCAML_BYTE_LINK_FLAGS: additional flags for byte compiler # OCAML_NATIVE_LINK_FLAGS: additional flags for native-code compiler # OCAML_LINK_FLAGS: general additional options (usually the -cclib options) # # \begin{doc} # \fun{OCamlProgram} # # The \verb+OCamlProgram+ function builds an OCaml program. It returns the array with all # the targets for which it has defined the rules (\verb+$(name)$(EXE)+ and \verb+$(name).run+ # and/or \verb+$(name).opt+, depending on the \verb+NATIVE_ENABLED+ and \verb+BYTE_ENABLED+ # variables). # # \verb+OCamlProgram(, )+ # # Additional variables used: # \begin{description} # \item[\hypervarxn{OCAML_LIBS}{OCAML\_LIBS}] Additional libraries passed to the linker, without suffix. These files # become dependencies of the target program. # \item[\hypervarxn{OCAML_OTHER_LIBS}{OCAML\_OTHER\_LIBS}] Additional libraries passed to the linker, without suffix. These # files do \emph{not} become dependencies of the target program. # \item[\hypervarxn{OCAML_CLIBS}{OCAML\_CLIBS}] C libraries to pass to the linker. # \item[\hypervarxn{OCAML_BYTE_LINK_FLAGS}{OCAML\_BYTE\_LINK\_FLAGS}] Flags to pass to the bytecode linker. # \item[\hypervarxn{OCAML_NATIVE_LINK_FLAGS}{OCAML\_NATIVE\_LINK\_FLAGS}] Flags to pass to the native code linker. # \item[\hypervarxn{OCAML_LINK_FLAGS}{OCAML\_LINK\_FLAGS}] Flags to pass to both linkers. # \end{description} # \end{doc} # public.OCamlProgram(name, files) = # XXX: JYH: these variables should be marked private in 0.9.9 protected.CMOFILES = $(addsuffix .cmo, $(files)) protected.CMXFILES = $(addsuffix .cmx, $(files)) protected.OFILES = $(addsuffix $(EXT_OBJ), $(files)) protected.CMAFILES = $(addsuffix .cma, $(OCAML_LIBS)) protected.CMXAFILES = $(addsuffix .cmxa, $(OCAML_LIBS)) protected.ARFILES = $(addsuffix $(EXT_LIB), $(OCAML_LIBS)) protected.CMA_OTHER_FILES = $(addsuffix .cma, $(OCAML_OTHER_LIBS)) protected.CMXA_OTHER_FILES = $(addsuffix .cmxa, $(OCAML_OTHER_LIBS)) protected.CLIBS = $(addsuffix $(EXT_LIB), $(OCAML_CLIBS)) protected.name = $(file $(name)) protected.PROG = $(file $(name)$(EXE)) protected.BYTEPROG = $(file $(name).run) protected.OPTPROG = $(file $(name).opt) # # Rules to build byte-code and native targets # $(BYTEPROG): $(CMAFILES) $(CMOFILES) $(CLIBS) $(OCAMLFIND) $(OCAMLLINK) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) $(OCAMLCFLAGS)\ $(PREFIXED_OCAMLINCLUDES) $(OCAML_BYTE_LINK_FLAGS)\ -o $@ $(CMA_OTHER_FILES) $(CMAFILES) $(OCamlLinkSort $(CMOFILES))\ $(CLIBS) $(OCAML_LINK_FLAGS) $(OPTPROG): $(CMXAFILES) $(ARFILES) $(CMXFILES) $(OFILES) $(CLIBS) $(OCAMLFIND) $(OCAMLOPTLINK) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) $(OCAMLOPTFLAGS)\ $(PREFIXED_OCAMLINCLUDES) $(OCAML_NATIVE_LINK_FLAGS)\ -o $@ $(CMXA_OTHER_FILES) $(CMXAFILES) $(OCamlLinkSort $(CMXFILES))\ $(CLIBS) $(OCAML_LINK_FLAGS) # # Link the actual executables. # Always prefer native executables. # if $(NATIVE_ENABLED) $(PROG): $(OPTPROG) ln-or-cp $< $@ else $(PROG): $(BYTEPROG) ln-or-cp $< $@ return $(array $(PROG), $(if $(NATIVE_ENABLED), $(OPTPROG)), $(if $(BYTE_ENABLED), $(BYTEPROG))) # # Copy to $(BIN) directory # # \begin{doc} # \fun{OCamlProgramCopy} # # The \verb+OCamlProgramCopy+ function copies an OCaml program to an install location. # # \verb+OCamlProgramCopy(, , )+ # # Additional variables used: # \begin{description} # \item[NATIVE\_ENABLED] If the \hypervarx{NATIVE_ENABLED}{NATIVE\_ENABLED} is set, the native-code executable # is copied; otherwise the byte-code executable is copied. # \end{description} # \end{doc} # public.OCamlProgramCopy(tag, bin, name) = private.name = $(file $(name)) private.BYTEPROG = $(file $(name).run) private.OPTPROG = $(file $(name).opt) private.SRCNAME = $(if $(NATIVE_ENABLED), $(OPTPROG), $(BYTEPROG)) private.BINNAME = $(file $(bin)/$(basename $(name))$(EXE)) # # Link the actual executables. # Always prefer native executables. # $(BINNAME): $(SRCNAME) $(bin) ln-or-cp $< $@ # Add to phony tag. $(tag): $(BINNAME) return $(BINNAME) # # We often use them together # # \begin{doc} # \fun{OCamlProgramInstall} # # The \verb+OCamlProgramInstall+ function builds a programs and copies it to # an install location in one step. # # \verb+OCamlProgramInstall(, , , )+ # \end{doc} # public.OCamlProgramInstall(tag, bin, name, files) = OCamlProgram($(name), $(files)) return $(OCamlProgramCopy $(tag), $(bin), $(name)) # vim:tw=100:fo=tcq: omake-0.10.3/lib/build/LaTeX.install0000644000175000017500000003633613177364666015563 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) ######################################################################## # Building LaTeX documents. # # Copyright (C) 2003-2007 Jason Hickey and Mojave Group # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. open build/Common ######################################################################## # LaTeX Section # # # LaTeX config # # \begin{doc} # \section{Building \LaTeX\ files} # # \OMake{} provides support for building \LaTeX\ documents, including support for automatically # running BiBTex and for producing PostScript and PDF files. In order to use the functions # defined in this section, you need to make sure the line # \begin{verbatim} # open build/LaTeX # \end{verbatim} # is present in your \verb+OMakeroot+ file. # # \subsection{Configuration variables} # # The following variables can be modified in your project. # \var{LATEX} The \LaTeX\ command (default \verb+latex+). # \varlabel{TETEX2_ENABLED}{TETEX2\_ENABLED} Flag indicating whether to use advanced \LaTeX\ options # present in TeTeX v.2 (default value is determined the first time omake reads \verb+LaTeX.src+ # and depends on the version of \LaTeX\ you have installed). # \var{LATEXFLAGS} The \LaTeX\ flags (defaults depend on the \verb+TETEX2_ENABLED+ variable) # \var{BIBTEX} The BibTeX command (default \verb+bibtex+). # \var{MAKEINDEX} The command to build an index (default \verb+makeindex+). # \var{DVIPS} The \verb+.dvi+ to PostScript converter (default \verb+dvips+). # \var{DVIPSFLAGS} Flags to pass to \verb+dvips+ (default \verb+-t letter+). # \var{DVIPDFM} The \verb+.dvi+ to \verb+.pdf+ converter (default \verb+dvipdfm+). # \var{DVIPDFMFLAGS} Flags to pass to \verb+dvipdfm+ (default \verb+-p letter+). # \var{PDFLATEX} The \verb+.latex+ to \verb+.pdf+ converter (default \verb+pdflatex+). # \var{PDFLATEXFLAGS} Flags to pass to pdflatex (default is \verb+$`(LATEXFLAGS)+). # \var{USEPDFLATEX} Flag indicating whether to use pdflatex instead of dvipdfm # to generate the \verb+.pdf+ document (default \verb+false+). # \end{doc} # declare public.LATEXFLAGS public.BIBTEX = bibtex public.MAKEINDEX = makeindex public.DVIPS = dvips public.DVIPSFLAGS = -t letter $`(if $(VERBOSE), $(EMPTY), -q) public.DVIPDFM = dvipdfm public.DVIPDFMFLAGS = -p letter public.PDFLATEX = pdflatex public.PDFLATEXFLAGS = $`(LATEXFLAGS) public.USEPDFLATEX = false public.LATEX = latex # # Configure LaTeX by checking whether some LaTeX options exist. # public. = declare FORCE_WIN32_LATEX if $(not $(defined FORCE_WIN32_LATEX)) FORCE_WIN32_LATEX = false export .STATIC: open configure/Configure # # XXX: JYH: when Cygwin latex is called from Win32, # it often segfaults, and pops up an annoying # ignore/abort window. Try to detect this case # and disable LaTeX. # # XXX: We should move the uname test into configure/uname. # OUTPUT_COMMENT_SUPPORTED = false TETEX2_ENABLED = false FILE_LINE_ERROR = LATEX_USABLE = $(CheckProg latex) if $(and $(LATEX_USABLE), $(not $(FORCE_WIN32_LATEX)), $(equal $(OSTYPE), Win32), $(CheckProg uname)) match($(shell uname)) case CYGWIN ConfMsgWarn($""" You seem to be trying to use Cygwin LaTeX on a Win32 machine. This usually doesn't work, but if you really want to use it, add the following definition to your OMakeroot. FORCE_WIN32_LATEX = true (latex disabled)""") LATEX_USABLE = false export export if $(and $(LATEX_USABLE), $(shell-success-null latex -help)) ConfMsgChecking(LaTeX capabilities) # # Various versions of LaTeX use different options # Look through the -help info for tetex2 options # RECORDER_ENABLED = false ERROR_ENABLED = false BROKEN_MIKTEX = false TETEX_CONFIG_TMP = $(tmpfile tetex) latex -help > $(TETEX_CONFIG_TMP) awk($(TETEX_CONFIG_TMP)) case ^-recorder RECORDER_ENABLED = true export case $'.*-recorder.*Record file names\.' # MikTeX 2.4 had a bug, where -recorder would swap inputs with outputs - # http://bugzilla.metaprl.org/show_bug.cgi?id=632 BROKEN_MIKTEX = true export case $'^ *-output-comment=' OUTPUT_COMMENT_SUPPORTED = true export case $'^ *-recorder' RECORDER_ENABLED = true export case ^-file-line-error-style FILE_LINE_ERROR = -file-line-error-style ERROR_ENABLED = true export case $'^\[-no\]-file-line-error' FILE_LINE_ERROR = -file-line-error ERROR_ENABLED = true export case $'^ *-c-style-errors' FILE_LINE_ERROR = -c-style-errors ERROR_ENABLED = true export # # TeTeX2 if both the -recorder and -file-line-error options exist # RECORDER_ENABLED = $(and $(RECORDER_ENABLED), $(not $(BROKEN_MIKTEX))) TETEX2_ENABLED = $(and $(RECORDER_ENABLED), $(ERROR_ENABLED)) ConfMsgResult(tetex2 mode $(if $(TETEX2_ENABLED), enabled, disabled)) rm $(TETEX_CONFIG_TMP) export FILE_LINE_ERROR TETEX2_ENABLED OUTPUT_COMMENT_SUPPORTED # # Compute the default flags # LATEXFLAGS_BASE = $(if $(OUTPUT_COMMENT_SUPPORTED), $'-output-comment=LaTeX Output (built with OMake)') export TETEX2_ENABLED FILE_LINE_ERROR LATEX_USABLE OUTPUT_COMMENT_SUPPORTED LATEXFLAGS_BASE LATEXFLAGS() = if $(TETEX2_ENABLED) value $(FILE_LINE_ERROR) $(LATEXFLAGS_BASE) else value $'-interaction=errorstopmode' $(LATEXFLAGS_BASE) # # Dynamically defined list of files that the TeX source depends on. # public.TEXDEPS = # # Directories in the search path. # Split them at colons to get a directory list. # public.TEXINPUTS = $(split $(PATHSEP), $(getenv TEXINPUTS, .)) # # TeX can log its inputs and outputs into an .fls file. We use the internal awk # to turn an .fls file into in appropriate dependency file format. # Shell. += protected.builtin-tex-deps(argv) = private. = dep = $(nth 0, $(argv)) f = $(nth 1, $(argv)) public. = DEPS[] = WRITES[] = $(file $f.bbl $f.ind) DEPDIR = $(dir .) awk($f.fls) case $'^PWD \(.*\)$' DEPDIR = $(dir $1) export case $'^INPUT \(.*\)$' DEPS += $(cd $(DEPDIR), $(file $1)) export case $'^OUTPUT \(.*\)$' WRITES += $(cd $(DEPDIR), $(file $1)) export if $(file-exists $f.aux) FS=$'[{}]' awk($f.aux) case $'\\bibdata\{.*\}' BIBS = $(split \,, $2) BIBS[] = $(BIBS) $(addsuffix .bib, $(BIBS)) DEPS += $(find-in-path-optional $(split \:, $(getenv BIBINPUTS)), $(BIBS)) export DEPS case $'\\bibstyle\{.*\}' BSTS = $(split \,, $2) BSTS[] = $(BSTS) $(addsuffix .bst, $(BSTS)) DEPS += $(find-in-path-optional $(split \:, $(getenv BSTINPUTS)), $(BSTS)) export DEPS export DEPS DEPS = $(set-diff $(DEPS), $(WRITES)) println($"$(string-escaped $(dep)): $(string-escaped $(DEPS))") eprintln($"$(string-escaped $(dep)): $(string-escaped $(DEPS))") protected.stdout-to-stderr(argv) = stdout = $(stderr) $(argv) protected.run-latex(argv) = if $(TETEX2_ENABLED) if $(not $(shell-success $(argv))) private.f = $(replacesuffixes .tex, $(string $(EMPTY)), $(last $(argv))) eprintln(*** Errors detected while running LaTeX on $(private.f).tex:) stdout-to-stderr grep ':[1-9][0-9]*: ' $(private.f).log exit 1 else $(argv) # # Rules for building TeX documents. # # name: the name of the document # texfiles: the TeX source files, without suffix # # Dynamic variables: # TEXINPUTS: extra directories to include in the search path # TEXDEPS: files that are implicitly included, including suffixes # # \begin{doc} # \subsection{Building \LaTeX\ documents} # \fun{LaTeXDocument} # # The \verb+LaTeXDocument+ produces a \LaTeX\ document. # # \verb+LaTeXDocument(, )+ # # The document \verb++ and \verb++ are listed without suffixes. This function # returns the filenames for the generated \verb+.ps+ (unless \hypervar{USEPDFLATEX} is set) and \verb+.pdf+ files. # # Additional variables used: # \var{TEXINPUTS} # The \LaTeX\ search path (an array of directories, default is # taken from the \verb+TEXINPUTS+ environment variable). # \var{TEXDEPS} Additional files this document depends on. # \var{TEXVARS} An array of names of the environment variables # that are to be updated based on the value of \OMake's \verb+TEXINPUTS+ variable. # Defaults to \verb+TEXINPUTS+ \verb+BIBINPUTS+ \verb+BSTINPUTS+. # \end{doc} # # Make sure generated files are built before scanning # # \begin{doc} # \twofuns{TeXGeneratedFiles}{LocalTeXGeneratedFiles} # \begin{verbatim} # TeXGeneratedFiles(files) # LocalTeXGeneratedFiles(files) # \end{verbatim} # # The \verb+TeXGeneratedFiles+ and \verb+LocalTeXGeneratedFiles+ functions specify files # that need to be generated before any \LaTeX files are scanned for dependencies. For example, # if \verb+config.tex+ and \verb+inputs.tex+ are both generated files, specify: # \begin{verbatim} # TeXGeneratedFiles(config.tex inputs.tex) # \end{verbatim} # # The \verb+TeXGeneratedFiles+ function is \emph{global} --- its arguments will be generated # before any TeX files anywhere in the project are scanned for dependencies. The # \verb+LocalTeXGeneratedFiles+ function follows the normal scoping rules of \OMake. # # \end{doc} public.TEXVARS[] = TEXINPUTS BIBINPUTS BSTINPUTS .PHONY: TeXGeneratedFilesTarget public.TeXGeneratedFiles(files) = TeXGeneratedFilesTarget: $(files) public.LocalTeXGeneratedFiles(files) = .SCANNER: scan-tex-%: $(files) export Shell. += protected.drop-dvips-junk(argv) = private.print = true awk() case $'dvips: Could not find figure file pdf:[a-z]*; continuing': print = false export case $'dvips: Unknown keyword [(].*[)] in \\special will be ignored': print = false export case $"dvips: more errors in special, being ignored": print = false export case $"dvips: [(]perhaps dvips doesn't support your macro package[?][)]": print = false export default if $(print) println($0) print = true export return true public.LaTeXDocument(name, texfiles) = name = $(file $(name)) # # TeX files all have the .tex suffix # protected.TEXFILES[] = $(name).tex $(addsuffix .tex, $(texfiles)) # # Setting the proper TEXINPUTS environment # private.INPUTS = $(concat $(PATHSEP), $(TEXINPUTS))$(PATHSEP) foreach(var => ..., $(TEXVARS)) setenv($(var), $(private.INPUTS)) export private.prog = $(if $(USEPDFLATEX), $(PDFLATEX), $(LATEX)) private.flags = $(if $(USEPDFLATEX), $(PDFLATEXFLAGS), $(LATEXFLAGS)) private.ext = $(if $(USEPDFLATEX), .pdf, .dvi) $(name)$(ext): $(TEXDEPS) $(TEXFILES) :effects: $(name).aux $(name).log $(name).ind $(name).out if $(gt $(length $(TEXVARS)), 0) echo "Enviroment variables $(concat $', ', $(TEXVARS)) set to $(getenv $(nth 0, $(TEXVARS)))" run-latex $(prog) $(flags) $(name) if $(and $(file-exists $(name).aux), $(grep q, $'\\citation', $(name).aux), $(grep q, $'\\bibdata', $(name).aux)) $(BIBTEX) $(name) run-latex $(prog) $(flags) $(name) if $(and $(file-exists $(name).idx), $(grep q, $'\\indexentry', $(name).idx)) $(MAKEINDEX) $(name) run-latex $(prog) $(flags) $(name) if $(grep q, $'Rerun to get', $(name).log) run-latex $(prog) $(flags) $(name) if $(grep q, $'Rerun to get', $(name).log) run-latex $(prog) $(flags) $(name) if $(grep q, $'Rerun to get', $(name).log) run-latex $(prog) $(flags) $(name) # # TeTeX2 has the ability to compute dependencies for us # if $(TETEX2_ENABLED) protected.SCANNER = scan-$(if $(USEPDFLATEX), pdflatex, latex)-$(name).tex .SCANNER: $(SCANNER): $(name).tex $(TEXDEPS) $(TEXFILES) /.PHONY/TeXGeneratedFilesTarget\ :value: $(USEPDFLATEX) $(find-in-path-optional $(INPUTS), $&)\ :effects: $(name).aux $(name).log $(name).ind $(name).out $(name).dvi $(name).fls echo | run-latex stdout-to-stderr $(prog) $(flags) -recorder $< builtin-tex-deps $(name)$(ext) $(name) $(name)$(ext): :scanner: $(SCANNER) if $(USEPDFLATEX) return $(file $(name).pdf) else $(name).pdf: $(name).dvi $(DVIPDFM) $(DVIPDFMFLAGS) -o $@ $(name).dvi if $(VERBOSE) $(name).ps: $(name).dvi $(DVIPS) $(DVIPSFLAGS) -o $@ $(name).dvi else $(name).ps: $(name).dvi $(DVIPS) $(DVIPSFLAGS) -o $@ $(name).dvi |& drop-dvips-junk return $(file $(name).ps $(name).pdf) # # Copy the document to a library directory # # \begin{doc} # \fun{LaTeXDocumentCopy} # # The \verb+LaTeXDocumentCopy+ copies the document to an install location. # # \verb+LaTeXDocumentCopy(, , , )+ # # This function copies just the \verb+.pdf+ and \verb+.ps+ files. # \end{doc} # public.LaTeXDocumentCopy(tag, lib, dst, src) = $(lib)/$(dst).pdf: $(src).pdf $(lib) :scanner: $(NOSCANNER) cp $< $@ $(lib)/$(dst).ps: $(src).ps $(lib) :scanner: $(NOSCANNER) cp $< $@ $(tag): $(lib)/$(dst).pdf $(lib)/$(dst).ps return $(file $(lib)/$(dst).pdf $(lib)/$(dst).ps) # # Build the document and copy it # # \begin{doc} # \fun{LaTeXDocumentInstall} # # The \verb+LaTeXDocumentInstall+ builds a document and copies it to an # install location in one step. # # \verb+LaTeXDocumentInstall(, , , , )+ # \end{doc} # public.LaTeXDocumentInstall(tag, lib, dst, src, texfiles) = LaTeXDocument($(src), $(texfiles)) return $(LaTeXDocumentCopy $(tag), $(lib), $(dst), $(src)) omake-0.10.3/lib/build/Common.install0000644000175000017500000001330613177364666016026 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) ######################################################################## # General configuration. # # Copyright (C) 2003-2005 Jason Hickey and Mojave Group # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. ######################################################################## # Mention a few of the other standard variables here. # # \begin{doc} # \section{The OMakeroot file} # \index{OMakeroot} # # The standard \File{OMakeroot} file defines the functions are rules # for building standard projects. # # \subsection{Variables} # \var{ROOT} The root directory of the current project. # \var{CWD} The current working directory (the directory is set for each \File{OMakefile} in the project). # \var{EMPTY} The empty string. # \var{STDROOT} The name of the standard installed \File{OMakeroot} file. # \end{doc} # ROOT = $(dir .) LIB = $(dir lib) BIN = $(dir bin) # # A default sort rule # .ORDER: .BUILDORDER # # \begin{doc} # \varlabel{ABORT_ON_COMMAND_ERROR}{ABORT\_ON\_COMMAND\_ERROR} If set to true, the construction of a target should # be aborted whenever one of the commands to build it fail. This defaults to true, # and should normally be left that way. # # \varlabel{SCANNER_MODE}{SCANNER\_MODE} This variable should be defined as one of four values # (defaults to \verb+enabled+). # \begin{description} # \item[enabled] Allow the use of default \verb+.SCANNER+ rules. Whenever a rule does # not specify a \verb+:scanner:+ dependency explicitly, try to find a # \verb+.SCANNER+ with the same target name. # \item[disabled] Never use default \verb+.SCANNER+ rules. # \item[warning] Allow the use of default \verb+.SCANNER+ rules, but print a warning # whenever one is selected. # \item[error] Do not allow the use of default \verb+.SCANNER+ rules. If a rule # does not specify a \verb+:scanner:+ dependency, and there is a default # \verb+.SCANNER+ rule, the build will terminate abnormally. # \end{description} # \end{doc} # # These are defined in Omake_builtin_base # ABORT_ON_COMMAND_ERROR = true # SCANNER_MODE = enabled ######################################################################## # Generic Unix section # # # \begin{doc} # \subsection{System variables} # # \var{INSTALL} The command to install a program (\verb+install+ on \verb+Unix+, \verb+cp+ on \verb+Win32+). # \var{PATHSEP} The normal path separator (\verb+:+ on \verb+Unix+, \verb+;+ on \verb+Win32+). # \var{DIRSEP} The normal directory separator (\verb+/+ on \verb+Unix+, \verb+\+ on \verb+Win32+). # \varlabel{EXT_OBJ}{EXT\_OBJ} File suffix for an object file (default is \verb+.o+ on \verb+Unix+, and \verb+.obj+ on \verb+Win32+). # \varlabel{EXT_LIB}{EXT\_LIB} File suffix for a static library (default is \verb+.a+ on \verb+Unix+, and \verb+.lib+ on \verb+Win32+). # \varlabel{EXT_DLL}{EXT\_DLL} File suffix for a shared library (default is \verb+.so+ on \verb+Unix+, and \verb+.dll+ on \verb+Win32+). # \varlabel{EXT_ASM}{EXT\_ASM} File suffix for an assembly file (default is \verb+.s+ on \verb+Unix+, and \verb+.asm+ on \verb+Win32+). # \var{EXE} File suffix for executables (default is empty for \verb+Unix+, and \verb+.exe+ on \verb+Win32+ and \verb+Cygwin+). # \end{doc} # # # These commands are builtin, and they are the same on all platforms. # The uppercase variables are defined for backwards compatibility only, # their usage is deprecated. # CP = cp MV = mv RM = rm -f MKDIR = mkdir RMDIR = rmdir CHMOD = chmod # We now support both msvc and mingw for Win32. CCOMPTYPE is "msvc" for the # former case and "cc" for the latter. There is some fallback code for old # omake bootstraps, though: if $(not $(defined CCOMPTYPE)) if $(equal $(OSTYPE), Win32) CCOMPTYPE = msvc export else CCOMPTYPE = cc export export #println(ccomptype: $(CCOMPTYPE)) switch $(CCOMPTYPE) case cc EXT_LIB = .a EXT_DLL = .so # but may be overridden below EXT_OBJ = .o EXT_ASM = .s EXE = # but may be overridden below export case msvc EXT_LIB = .lib EXT_DLL = .dll EXT_OBJ = .obj EXT_ASM = .asm EXE = .exe export if $(equal $(OSTYPE), Win32) # # Command names # INSTALL = cp PATHSEP = ; DIRSEP = \\ # # Common suffixes for files # EXT_DLL = .dll EXE = .exe export else # # Command names # INSTALL = install PATHSEP = : DIRSEP = / export if $(equal $(OSTYPE), Cygwin) EXE = .exe export declare LN if $(not $(defined USE_SYSTEM_COMMANDS)) if $(not $(equal $(OSTYPE), Win32)) LN = ln -sf export export else LN = ln-or-cp export # XXX: JYH: this is a total hack. # It should be the case the :scanner: $(EMPTY) turns off scanners. # NOSCANNER = /scan-dummy .SCANNER: $(NOSCANNER) @ omake-0.10.3/lib/build/svn_realclean.install0000644000175000017500000000771713177364666017423 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) ######################################################################## # Copyright (C) 2006 Aleksey Nogin # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. ######################################################################## # This file defines an svn_realclean utility. The svn_realclean utility removes # all unversioned files in a subversion wc. # # Usage: svn_realclean [options] [dir1 [dir2 ...]] # Options are: # -f Do not ask whether to remove files # -i Ignore the file # -help Display this list of options # --help Display this list of options # If no directories are given, . is used. open configure/Configure .STATIC: SVN_AVAILABLE = $(CheckProg svn) Shell. += do_clean(IGNORES) = awk() case $'^[I?] ' f = $(file $2) if $(not $(mem $f, $(IGNORES))) println($"Removing $f...") rm -rf $f svn_realclean(argv) = if $(SVN_AVAILABLE) usage(msg,err) = println($"""$(msg) Usage: svn_realclean [options] [dir1 [dir2 ...]] Options are: -f Do not ask whether to remove files -i Ignore the file -help Display this list of options --help Display this list of options If no directories are given, . is used. """) exit($(err)) FORCE=false IGNORES[]= DIRS[] = $(dir .) while $(gt $(length $(argv)), 0) match $(nth 0, $(argv)) case $'^-f$' FORCE=true argv = $(nth-tl 1, $(argv)) export case $'^-i$' if $(gt $(length $(argv)), 1) IGNORES[] += $(file $(nth 1, $(argv))) argv = $(nth-tl 2, $(argv)) export else usage($"The -i option requires an argument", 1) export case $'^--?help$' usage($"The svn_realclean utility removes all unversioned files in a subversion wc.", 0) case $'^-' usage($"Unknown option: $(nth 0, $(argv))", 1) default DIRS[] = $(dir $(argv)) export if $(FORCE) svn st --no-ignore $(DIRS) | do_clean $(IGNORES) else # rm -ri will require a real stdin, so we can not use the same # "svn ... | do_clean" pipeline here. tmp = $(tmpfile svn_realclean) svn st --no-ignore $(DIRS) > $(tmp) awk($(tmp)) case $'^[I?] ' f = $(file $2) if $(not $(mem $f, $(IGNORES))) # println($"Removing $f...") rm -ri $f rm -f $(tmp) else eprintln($"svn_realclean requires the svn binary, but svn is missing") exit(1) # vim:tw=80:ts=4:et omake-0.10.3/lib/build/svn_realclean.om0000644000175000017500000000762013177364666016361 0ustar gerdgerd######################################################################## # Copyright (C) 2006 Aleksey Nogin # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. ######################################################################## # This file defines an svn_realclean utility. The svn_realclean utility removes # all unversioned files in a subversion wc. # # Usage: svn_realclean [options] [dir1 [dir2 ...]] # Options are: # -f Do not ask whether to remove files # -i Ignore the file # -help Display this list of options # --help Display this list of options # If no directories are given, . is used. open configure/Configure .STATIC: SVN_AVAILABLE = $(CheckProg svn) Shell. += do_clean(IGNORES) = awk() case $'^[I?] ' f = $(file $2) if $(not $(mem $f, $(IGNORES))) println($"Removing $f...") rm -rf $f svn_realclean(argv) = if $(SVN_AVAILABLE) usage(msg,err) = println($"""$(msg) Usage: svn_realclean [options] [dir1 [dir2 ...]] Options are: -f Do not ask whether to remove files -i Ignore the file -help Display this list of options --help Display this list of options If no directories are given, . is used. """) exit($(err)) FORCE=false IGNORES[]= DIRS[] = $(dir .) while $(gt $(length $(argv)), 0) match $(nth 0, $(argv)) case $'^-f$' FORCE=true argv = $(nth-tl 1, $(argv)) export case $'^-i$' if $(gt $(length $(argv)), 1) IGNORES[] += $(file $(nth 1, $(argv))) argv = $(nth-tl 2, $(argv)) export else usage($"The -i option requires an argument", 1) export case $'^--?help$' usage($"The svn_realclean utility removes all unversioned files in a subversion wc.", 0) case $'^-' usage($"Unknown option: $(nth 0, $(argv))", 1) default DIRS[] = $(dir $(argv)) export if $(FORCE) svn st --no-ignore $(DIRS) | do_clean $(IGNORES) else # rm -ri will require a real stdin, so we can not use the same # "svn ... | do_clean" pipeline here. tmp = $(tmpfile svn_realclean) svn st --no-ignore $(DIRS) > $(tmp) awk($(tmp)) case $'^[I?] ' f = $(file $2) if $(not $(mem $f, $(IGNORES))) # println($"Removing $f...") rm -ri $f rm -f $(tmp) else eprintln($"svn_realclean requires the svn binary, but svn is missing") exit(1) # vim:tw=80:ts=4:et omake-0.10.3/lib/build/C.om0000644000175000017500000006244213177364666013732 0ustar gerdgerd######################################################################## # Building C files. # # Copyright (C) 2003-2007 Jason Hickey and Mojave Group # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. open build/Common open configure/Configure # # \begin{doc} # \section{Building C and C++ code} # # \OMake{} provides extensive support for building C and C++ programs. In order to use the functions # defined in this section, you need to make sure the line # \begin{verbatim} # open build/C # \end{verbatim} # is present in your \verb+OMakeroot+ file. # # \subsection{Autoconfiguration variables} # These variables will get defined based on the ``autoconf-style'' \verb+static.+ tests executed # when you run \OMake{} for the first time. You can use them to configure your project accordingly, # and you should not redefine them. # # You can use the \verb+--configure+ command line option (Section~\ref{option:--configure}) to force # re-execution of all the tests. # # A different set of autoconfiguration tests is performed depending on the build environment # involved --- one set of tests would be performed in a \verb+Win32+ environment, and another --- # in a Unix-like environment (including Linux, OS X and Cygwin). # # \subsubsection{Unix-like systems} # \varlabel{GCC_FOUND}{GCC\_FOUND} A boolean flag specifying whether the \verb+gcc+ binary was found in your path. # \varlabel{GXX_FOUND}{GXX\_FOUND} A boolean flag specifying whether the \verb.g++. binary was found in your path. # # \subsubsection{Win32} # \varlabel{CL_FOUND}{CL\_FOUND} A boolean flag specifying whether the \verb+cl+ binary was found in your path. # \varlabel{LIB_FOUND}{LIB\_FOUND} A boolean flag specifying whether the \verb+lib+ binary was found in your path. # # \subsection{C and C++ configuration variables} # # The following variables can be redefined in your project. # # \var{CC} The name of the C compiler (on \verb+Unix+ it defaults to \verb+gcc+ when \verb+gcc+ is present and # to \verb+cc+ otherwise; on \verb+Win32+ defaults to \verb+cl /nologo+). # \var{CXX} The name of the C++ compiler (on \verb+Unix+ it defaults to \verb+gcc+ when \verb+gcc+ is present # and to \verb+c+++ otherwise; on \verb+Win32+ defaults to \verb+cl /nologo+). # \var{CPP} The name of the C preprocessor (defaults to \verb+cpp+ on \verb+Unix+, and \verb+cl /E+ on \verb+Win32+). # \var{CFLAGS} Compilation flags to pass to the C compiler (default empty on \verb+Unix+, and \verb+/DWIN32+ # on \verb+Win32+). # \var{CXXFLAGS} Compilation flags to pass to the C++ compiler (default empty on \verb+Unix+, and \verb+/DWIN32+ # on \verb+Win32+). # \var{INCLUDES} Additional directories that specify the search path to the C and C++ compilers (default is \verb+.+). # The directories are passed to the C and C++ compilers with the \verb+-I+ option. # The include path with \verb+-I+ prefixes is defined in the \verb+PREFIXED_INCLUDES+ variable. # \var{LIBS} Additional libraries needed when building a program (default is empty). # \var{CCOUT} The option to use for specifying the output file in C and C++ compilers # (defaults to \verb+-o+ on \verb+Unix+ and \verb+/Fo+ on \verb+Win32+). # \var{AS} The name of the assembler (defaults to \verb+as+ on \verb+Unix+, and \verb+ml+ on \verb+Win32+). # \var{ASFLAGS} Flags to pass to the assembler (default is empty on \verb+Unix+, and \verb+/c /coff+ # on \verb+Win32+). # \var{ASOUT} The option string that specifies the output file for \verb+AS+ (defaults to \verb+-o+ # on \verb+Unix+ and \verb+/Fo+ on \verb+Win32+). # \var{AR} The name of the program to create static libraries (defaults to \verb+ar cq+ on \verb+Unix+, # and \verb+lib+ on \verb+Win32+). # \var{LD} The name of the linker (defaults to \verb+ld+ on \verb+Unix+, and \verb+cl+ on \verb+Win32+). # \var{LDFLAGS} Options to pass to the linker (default is empty). # \varlabel{LDFLAGS_DLL}{LDFLAGS\_DLL} Options to pass to the linker when compiling a shared library (defaults to \verb+-shared+ on \verb+Unix+ and \verb+/DLL+ on \verb+Win32+). # \var{LDOUT} The option to use for specifying the output file in C and C++ linkers # (defaults to \verb+-o+ on \verb+Unix+ and \verb+/Fe+ on \verb+Win32+). # \var{YACC} The name of the \verb+yacc+ parser generator (default is \verb+yacc+ on \verb+Unix+, empty on \verb+Win32+). # \var{LEX} The name of the \verb+lex+ lexer generator (default is \verb+lex+ on \verb+Unix+, empty on \verb+Win32+). # \end{doc} # # derive a toolchain name, e.g. # toolchain-derive(foo-gcc, g++, fallback) = "foo-g++" # if foo-g++ exists, and fallback otherwise protected.toolchain-derive(cc, command, fallback) = empty = $(array) match $(cc) case $"\(.*\)-g?cc" fullcmd = $(concat $(empty), $1 $(command)) if $(exists-in-path $(fullcmd)) return $(fullcmd) else return $(fallback) default return $(fallback) # by default, we pick the C compiler that was used for building omake. # When upgrading omake, this might not be set, so fall back to the old # magic. .STATIC: # C compiler if $(equal $(CCOMPTYPE), msvc) CL_FOUND = $(CheckProg cl) LIB_FOUND = $(CheckProg lib) export else protected.GCC_FOUND1 = $(CheckProg gcc) protected.GXX_FOUND1 = $(and $(GCC_FOUND1), $(CheckProg g++)) export if $(defined OMAKE_CC) DEFAULT_CC = $(OMAKE_CC) export else if $(equal $(CCOMPTYPE), msvc) DEFAULT_CC = cl export else DEFAULT_CC = $(if $(GCC_FOUND1), gcc, cc) export export DEFAULT_CC_FOUND = $(CheckProg $(DEFAULT_CC)) DEFAULT_GCC_FOUND = false match $(DEFAULT_CC) case $"\.*-gcc" DEFAULT_GCC_FOUND = true export case $"gcc" DEFAULT_GCC_FOUND = true export if $(equal $(CCOMPTYPE), msvc) DEFAULT_CC += /nologo export # C++ compiler if $(equal $(CCOMPTYPE), msvc) DEFAULT_CXX = cl /nologo export else DEFAULT_CXX = $(toolchain-derive $(DEFAULT_CC), g++, $`(toolchain-derive $(DEFAULT_CC), c++, $(if $(GXX_FOUND1), g++, c++))) export DEFAULT_CXX_FOUND = $(CheckProg $(nth 0, $(DEFAULT_CXX))) DEFAULT_GXX_FOUND = false match $(DEFAULT_CXX) case $"\.*-g++" DEFAULT_GXX_FOUND = true export case $"g++" DEFAULT_GXX_FOUND = true export # C preprocessor if $(equal $(CCOMPTYPE), msvc) DEFAULT_CPP = cl /nologo /E export else DEFAULT_CPP = $(toolchain-derive $(DEFAULT_CC), cpp, $(DEFAULT_CC) -E) export DEFAULT_CPP_FOUND = $(CheckProg $(nth 0, $(DEFAULT_CPP))) # linker if $(equal $(CCOMPTYPE), msvc) DEFAULT_LD = cl /nologo export else DEFAULT_LD = $(toolchain-derive $(DEFAULT_CC), ld, ld) export DEFAULT_LD_FOUND = $(CheckProg $(nth 0, $(DEFAULT_LD))) # assembler if $(equal $(CCOMPTYPE), msvc) DEFAULT_AS = ml /nologo export else DEFAULT_AS = $(toolchain-derive $(DEFAULT_CC), as, as) export DEFAULT_AS_FOUND = $(CheckProg $(nth 0, $(DEFAULT_AS))) export # At this point you could insert code updating DEFAULT_CC. declare protected.CC_DEFINE declare protected.OS_CFLAGS if $(equal $(CCOMPTYPE), msvc) CC_DEFINE = /D export else CC_DEFINE = -D export if $(equal $(OSTYPE), Win32) OS_CFLAGS = $(CC_DEFINE)WIN32 public.CDLL_IMPLIES_STATIC = true export else OS_CFLAGS = public.CDLL_IMPLIES_STATIC = false export if $(equal $(CCOMPTYPE), msvc) public.CC = $(DEFAULT_CC) public.CXX = $(DEFAULT_CXX) public.CPP = $(DEFAULT_CPP) public.CFLAGS = $(OS_CFLAGS) public.CXXFLAGS = $(OS_CFLAGS) public.AR(name) = return(lib /nologo /debugtype:CV /out:$(name)) public.RANLIB = echo ranlib public.INCLUDES[] = . public.INCLUDES_OPT = /I public.CCOUT = /Fo public.LD = $(DEFAULT_LD) public.YACC = echo yacc public.LEX = echo lex public.LIBS = public.LDFLAGS = public.LDFLAGS_DLL = /DLL public.LDOUT = /Fe public.AS = $(DEFAULT_AS) public.ASOUT = /Fo public.ASFLAGS = /c /coff export else public.CC = $(DEFAULT_CC) public.GCC_FOUND = $(DEFAULT_GCC_FOUND) public.CXX = $(DEFAULT_CXX) public.GXX_FOUND = $(DEFAULT_GXX_FOUND) public.CPP = $(DEFAULT_CPP) public.CFLAGS = $(OS_CFLAGS) public.CXXFLAGS = $(OS_CFLAGS) public.AR(name) = return(ar cq $(name)) public.RANLIB = ranlib public.LD = $(DEFAULT_LD) public.INCLUDES[] = . public.INCLUDES_OPT = -I public.CCOUT = $(array -o) public.YACC = yacc public.LEX = lex public.LIBS = public.LDFLAGS = public.LDOUT = $(array -o) # MacOS X specific config if $(equal $(SYSNAME), Darwin) public.LDFLAGS_DLL = -dynamiclib export else public.LDFLAGS_DLL = -shared export public.AS = $(DEFAULT_AS) public.ASOUT = $(array -o) public.ASFLAGS = export # # Add the -I option to the includes lazily. # Don't redefine this variable unless you know what you are doing. # public.PREFIXED_INCLUDES = $`(addprefix $(INCLUDES_OPT), $(INCLUDES)) # # Special flags for compiling C files for use in OCaml # public.BYTE_CFLAGS = public.NATIVE_CFLAGS = # # Generic build rules # # public.CXX_EXTS[] = .cpp .cc .c++ %$(EXT_OBJ): %.c :scanner: scan-c-%.c $(CC) $(CFLAGS) $(PREFIXED_INCLUDES) -c $(CCOUT)$@ $< foreach(CXX_EXT => ..., $(CXX_EXTS)) %$(EXT_OBJ): %$(CXX_EXT) :scanner: scan-cxx-%$(CXX_EXT) $(CXX) $(CXXFLAGS) $(PREFIXED_INCLUDES) -c $(CCOUT)$@ $< export %$(EXT_OBJ): %$(EXT_ASM) $(AS) $(ASFLAGS) $(PREFIXED_INCLUDES) $(ASOUT)$@ $< %.c: %.y $(YACC) $< %.c: %.l $(LEX) $< # # Default C scanner # # # Make sure generated files are built before scanning # # \begin{doc} # \subsection{Generated C files} # Because the C scanners do not normally know anything about generated source files (such as # generated header files), these files may need to be created before running the scanner. # \twofuns{CGeneratedFiles}{LocalCGeneratedFiles} # \begin{verbatim} # CGeneratedFiles(files) # LocalCGeneratedFiles(files) # \end{verbatim} # # The \verb+CGeneratedFiles+ and \verb+LocalCGeneratedFiles+ functions specify files # that need to be generated before any C files are scanned for dependencies. For example, # if \verb+config.h+ and \verb+inputs.h+ are both generated files, specify: # \begin{verbatim} # CGeneratedFiles(config.h inputs.h) # \end{verbatim} # # The \verb+CGeneratedFiles+ function is \emph{global} --- its arguments will be generated # before any C files anywhere in the project are scanned for dependencies. The # \verb+LocalCGeneratedFiles+ function follows the normal scoping rules of OMake. # # \end{doc} # .PHONY: CGeneratedFilesTarget public.CGeneratedFiles(files) = CGeneratedFilesTarget: $(files) public.LocalCGeneratedFiles(files) = .SCANNER: scan-c-%: $(files) .SCANNER: scan-cxx-%: $(files) .SCANNER: %$(EXT_OBJ): $(files) export # # We use digest-path-exists value dependency to make sure the SCANNER is re-run # whenever the scanned dependencies change. # if $(equal $(CCOMPTYPE), msvc) Shell. += builtin-cc-depend(argv) = filename = $(nth 0, $(argv)) depends[] = awk(b, $(stdin)) case $'Note:.*including file: *\(.*\)$' depends[] += $(file $"$1") export case $'Hinweis:.*Einlesen der Datei: *\(.*\)$' depends[] += $(file $"$1") export case $'.[(][0-9][0-9]*[)] : (warning|(fatal |)error) [A-Z][0-9]*: ' eprintln($0) depends = $(string-escaped $(set $(depends))) objname = $(string-escaped $(rootname $(filename))$(EXT_OBJ)) println($"$(objname): $(depends)") .SCANNER: scan-c-%.c: %.c /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) $(CC) $(CFLAGS) $(PREFIXED_INCLUDES) /w /Zs /showIncludes $< |& builtin-cc-depend $< # # Include default rule for backwards-compatibility # .SCANNER: %$(EXT_OBJ): %.c /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) # $(CC) $(CFLAGS) $(PREFIXED_INCLUDES) /Zs /showIncludes $< |& builtin-cc-depend $< foreach(CXX_EXT => ..., $(CXX_EXTS)) .SCANNER: scan-cxx-%$(CXX_EXT): %$(CXX_EXT) /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) $(CXX) $(CXXFLAGS) $(PREFIXED_INCLUDES) /w /Zs /showIncludes $< |& builtin-cc-depend $< # # Include default rule for backwards-compatibility # .SCANNER: %$(EXT_OBJ): %$(CXX_EXT) /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) # $(CXX) $(CXXFLAGS) $(PREFIXED_INCLUDES) /Zs /showIncludes $< |& builtin-cc-depend $< export export else .SCANNER: scan-c-%.c: %.c /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) $(CC) $(CFLAGS) $(PREFIXED_INCLUDES) -MM $< # # Include default rule for backwards-compatibility # .SCANNER: %$(EXT_OBJ): %.c /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) # $(CC) $(CFLAGS) $(PREFIXED_INCLUDES) -MM $< foreach(CXX_EXT => ..., $(CXX_EXTS)) .SCANNER: scan-cxx-%$(CXX_EXT): %$(CXX_EXT) /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) $(CXX) $(CXXFLAGS) $(PREFIXED_INCLUDES) -MM $< # # Include default rule for backwards-compatibility # .SCANNER: %$(EXT_OBJ): %$(CXX_EXT) /.PHONY/CGeneratedFilesTarget :value: $(digest-in-path-optional $(INCLUDES), $&) # $(CXX) $(CXXFLAGS) $(PREFIXED_INCLUDES) -MM $< export export # Define a function to build a C-library # # \begin{doc} # \subsection{Building C programs and Libraries} # \twofuns{StaticCLibrary}{DynamicCLibrary} # # The \verb+StaticCLibrary+ builds a static library and the \verb+DynamicCLibrary+ # function builds a shared library (DLL). # # \begin{verbatim} # StaticCLibrary(, ) # DynamicCLibrary(, ) # \end{verbatim} # # The \verb++ does \emph{not} include the library suffix, and # The \verb++ list does not include the object suffix. These # are obtained from the \hypervarxn{EXT_LIB}{EXT\_LIB} (\hypervarxn{EXT_DLL}{EXT\_DLL}) # and \hypervarxn{EXT_OBJ}{EXT\_OBJ} variables. # # This function returns the library filename. # # The following command builds the library \verb+libfoo.a+ from the # files \verb+a.o b.o c.o+ on \verb+Unix+, or the library # \verb+libfoo.lib+ from the files \verb+a.obj b.obj c.obj+ # on \verb+Win32+. # # \begin{verbatim} # StaticCLibrary(libfoo, a b c) # .DEFAULT: $(StaticCLibrary libbar, a b c d) # \end{verbatim} # # \varlabel{CDLL_IMPLIES_STATIC}{CDLL\_IMPLIES\_STATIC} If the \verb+CDLL_IMPLIES_STATIC+ # variable is enabled (this is default on \verb+Win32+), all the \verb+DynamicC+ functions # would assume that creating a shared library automatically created a static one. # \end{doc} # public.StaticCLibrary(name, files) = private.OFILES = $(addsuffix $(EXT_OBJ), $(files)) private.NORMALLIB = $(file $(name)$(EXT_LIB)) if $(equal $(OSTYPE), Win32) $(NORMALLIB): $(OFILES) echo $(OFILES) > $@.tmp $(AR $@) @$@.tmp rm -f $@.tmp else $(NORMALLIB): $(OFILES) rm -f $@ $(AR $@) $(OFILES) $(RANLIB) $@ return $(NORMALLIB) public.DynamicCLibrary(name, files) = private.OFILES = $(addsuffix $(EXT_OBJ), $(files)) private.LFILES = $(addsuffix $(EXT_LIB), $(LIBS)) private.LIB = $(file $(name)$(EXT_DLL)) private.TARGETS = $(LIB) if $(CDLL_IMPLIES_STATIC) TARGETS[] += $(file $(name)$(EXT_LIB)) export TARGETS $(TARGETS): $(OFILES) $(LFILES) $(CC) $(CFLAGS) $(LDOUT)$(LIB) $(OFILES) $(LFILES) $(LDFLAGS) $(LDFLAGS_DLL) return $(TARGETS) # # Copy to an install directory # # \begin{doc} # \twofuns{StaticCLibraryCopy}{DynamicCLibraryCopy} # # The \verb+StaticCLibraryCopy+ and \verb+DynamicCLibraryCopy+ functions copy a library # to an install location. # # \begin{verbatim} # StaticCLibraryCopy(, , ) # DynamicCLibraryCopy(, , ) # \end{verbatim} # # The \verb++ is the name of a target (typically a \verb+.PHONY+ target); # the \verb++ is the installation directory, and \verb++ is # the library to be copied (without the library suffix). # # This function returns the filename of the library in the target directory. # # For example, the following code copies the library # \verb+libfoo.a+ to the \verb+/usr/lib+ directory. # # \begin{verbatim} # .PHONY: install # # StaticCLibraryCopy(install, /usr/lib, libfoo) # \end{verbatim} # \end{doc} # public.StaticCLibraryCopy(tag, lib, name) = # # Names of libs # private.NORMALLIB = $(file $(name)$(EXT_LIB)) private.LIBNORMAL = $(file $(lib)/$(basename $(name))$(EXT_LIB)) # # Linking the library into the root lib dir # $(LIBNORMAL): $(NORMALLIB) $(lib) :scanner: $(NOSCANNER) ln-or-cp $< $@ # # Add dependency to the tag # $(tag): $(LIBNORMAL) return $(LIBNORMAL) public.DynamicCLibraryCopy(tag, lib, name) = TARGETS = EXT_LIB = $(EXT_DLL) value $(StaticCLibraryCopy $(tag), $(lib), $(name)) if $(CDLL_IMPLIES_STATIC) TARGETS[] += $(StaticCLibraryCopy $(tag), $(lib), $(name)) export TARGETS return $(TARGETS) # # We often use them together # # \begin{doc} # \twofuns{StaticCLibraryInstall}{DynamicCLibraryInstall} # # The \verb+StaticCLibraryInstall+ and \verb+DynamicCLibraryInstall+ functions build a library, and # set the install location in one step. Return the filename of the library # in the target directory. # # \begin{verbatim} # StaticCLibraryInstall(, , , ) # DynamicCLibraryInstall(, , , ) # \end{verbatim} # # \begin{verbatim} # StaticCLibraryInstall(install, /usr/lib, libfoo, a b c) # \end{verbatim} # \end{doc} # public.StaticCLibraryInstall(tag, lib, name, files) = StaticCLibrary($(name), $(files)) return $(StaticCLibraryCopy $(tag), $(lib), $(name)) public.DynamicCLibraryInstall(tag, lib, name, files) = DynamicCLibrary($(name), $(files)) return $(DynamicCLibraryCopy $(tag), $(lib), $(name)) # # Build a .o file. This is like a library, # but use the linker instead. # # \begin{doc} # \threefuns{StaticCObject}{StaticCObjectCopy}{StaticCObjectInstall} # # These functions mirror the \verb+StaticCLibrary+, \verb+StaticCLibraryCopy+, # and \verb+StaticCLibraryInstall+ functions, but they build an \emph{object} # file (a \verb+.o+ file on \verb+Unix+, and a \verb+.obj+ file on \verb+Win32+). # \end{doc} # public.StaticCObject(name, files) = # # Generic library that can be used on byte and native-code # private.OFILES = $(addsuffix $(EXT_OBJ), $(files)) # # Names of libs # private.NORMALLIB = $(file $(name)$(EXT_OBJ)) $(NORMALLIB): $(OFILES) $(LD) $(LDFLAGS) -r $(LDOUT)$@ $(OFILES) return $(NORMALLIB) # # Copy to an install directory # public.StaticCObjectCopy(tag, lib, name) = # # Names of libs # private.NORMALLIB = $(file $(name)$(EXT_OBJ)) private.LIBNORMAL = $(file $(lib)/$(basename $(name))$(EXT_OBJ)) # # Linking the library into the root lib dir # $(LIBNORMAL): $(NORMALLIB) $(lib) :scanner: $(NOSCANNER) ln-or-cp $< $@ # # Add dependency to the tag # $(tag): $(LIBNORMAL) return $(LIBNORMAL) # # We often use them together # public.StaticCObjectInstall(tag, lib, name, files) = StaticCObject($(name), $(files)) return $(StaticCObjectCopy $(tag), $(lib), $(name)) # # Define a function to build a C-program # # \begin{doc} # \fun{CProgram} # # The \verb+CProgram+ function builds a C program from a set # of object files and libraries. # # \verb+CProgram(, )+ # # The \verb++ argument specifies the name of the program to be built; # the \verb++ argument specifies the files to be linked. The function # returns the filename of the executable. # # Additional options can be passed through the following variables. # \begin{description} # \item[CFLAGS] Flags used by the C compiler during the link step. # \item[LDFLAGS] Flags to pass to the loader. # \item[LIBS] Additional libraries to be linked. # \end{description} # # For example, the following code specifies that the program # \verb+foo+ is to be produced by linking the files \verb+bar.o+ # and \verb+baz.o+ and libraries \verb+libfoo.a+. # # \begin{verbatim} # section # LIBS = libfoo # LDFLAGS += -lbar # CProgram(foo, bar baz) # \end{verbatim} # \end{doc} # public.CProgram(name, files) = # # Generic program # private.OFILES = $(addsuffix $(EXT_OBJ), $(files)) private.NAME = $(file $(name)$(EXE)) # # XXX: Backward compatibility: We used to confuse LIBS and LDFLAGS, so need to split things out. # private.FLAGS = $(filter -%, $(LIBS)) if $(FLAGS) eprintln($""!!! WARNING: the LIBS variable should not include link flags "$(FLAGS)";"") eprintln($""!!! those should go into LDFLAGS"") LDFLAGS += $(FLAGS) LIBS = $(filter-out -%, $(LIBS)) export if $(filter %$(EXT_LIB), $(LIBS)) eprintln($""!!! WARNING: the LIBS variable should contain libraries _without_ extensions."") LIBS = $(replacesuffixes $(EXT_LIB), $"$(EMPTY)", $(LIBS)) export private.LFILES = $(addsuffix $(EXT_LIB), $(LIBS)) $(NAME): $(OFILES) $(LFILES) $(CC) $(CFLAGS) $(LDOUT)$@ $,(OFILES) $(LFILES) $(LDFLAGS) return $(NAME) # # Copy to a bin directory # # \begin{doc} # \fun{CProgramCopy} # # The \verb+CProgramCopy+ function copies a file to an install location. # # \verb+CProgramCopy(, , )+ # # \begin{verbatim} # CProgramCopy(install, /usr/bin, foo) # \end{verbatim} # \end{doc} # public.CProgramCopy(tag, bin, name) = # # Name of the program # private.NAME = $(file $(name)$(EXE)) private.BINNAME = $(file $(bin)/$(basename $(name))$(EXE)) # # Linking the program into the root bin dir # $(BINNAME): $(NAME) $(bin) :scanner: $(NOSCANNER) ln-or-cp $< $@ # # Add the dependency to the tag # $(tag): $(BINNAME) return $(BINNAME) # # We often use them together # # \begin{doc} # \fun{CProgramInstall} # # The \verb+CProgramInstall+ function specifies a program to build, # and a location to install, simultaneously. # # \verb+CProgramInstall(, , , )+ # # \begin{verbatim} # section # LIBS = libfoo # LDFLAGS += -lbar # CProgramInstall(install, /usr/bin, foo, bar baz) # \end{verbatim} # \end{doc} # public.CProgramInstall(tag, bin, name, files) = CProgram($(name), $(files)) return $(CProgramCopy $(tag), $(bin), $(name)) # # The C++ versions. # # \begin{doc} # \twofuns{CXXProgram}{CXXProgramInstall} # # The \verb+CXXProgram+ and \verb+CXXProgramInstall+ functions are # equivalent to their C counterparts, except that would use \verb+$(CXX)+ and \verb+$(CXXFLAGS)+ # for linking instead of \verb+$(CC)+ and \verb+$(CFLAGS)+. # \end{doc} # public.CXXProgram(name, files) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(CProgram $(name), $(files)) public.CXXProgramInstall(tag, bin, name, files) = CXXProgram($(name), $(files)) return $(CProgramCopy $(tag), $(bin), $(name)) # \begin{doc} # \sixfuns{StaticCXXLibrary}{StaticCXXLibraryCopy}{StaticCXXLibraryInstall}{DynamicCXXLibrary}{DynamicCXXLibraryCopy}{DynamicCXXLibraryInstall} # # Similarly, the six \verb+CXXLibrary+ functions the C++ equivalents of the corresponding # \verb+CLibrary+ functions. # \end{doc} # public.StaticCXXLibrary(name, files) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(StaticCLibrary $(name), $(files)) public.StaticCXXLibraryCopy(tag, lib, name) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(StaticCLibraryCopy $(tag), $(lib), $(name)) public.StaticCXXLibraryInstall(tag, lib, name, files) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(StaticCLibraryInstall $(tag), $(lib), $(name), $(files)) public.DynamicCXXLibrary(name, files) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(DynamicCLibrary $(name), $(files)) public.DynamicCXXLibraryCopy(tag, lib, name) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(DynamicCLibraryCopy $(tag), $(lib), $(name)) public.DynamicCXXLibraryInstall(tag, lib, name, files) = CC = $(CXX) CFLAGS = $(CXXFLAGS) return $(DynamicCLibraryInstall $(tag), $(lib), $(name), $(files)) omake-0.10.3/lib/build/OCaml.om0000644000175000017500000014022313177364666014535 0ustar gerdgerd######################################################################## # Building OCaml programs. # # Copyright (C) 2003-2007 Jason Hickey and Mojave Group # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. open build/Common open configure/Configure ######################################################################## # OCaml section # # \begin{doc} # \section{Building OCaml code} # # \OMake{} provides extensive support for building OCaml code, including support for tools like # \verb+ocamlfind+, \verb+ocamlyacc+ and \verb+menhir+. In order to use the functions # defined in this section, you need to make sure the line # \begin{verbatim} # open build/OCaml # \end{verbatim} # is present in your \verb+OMakeroot+ file. # # \subsection{Autoconfiguration variables for OCaml compilation} # These variables will get defined based on the ``autoconf-style'' tests executed when you # run \OMake{} for the first time. You can use them to configure your project accordingly, # and you should not redefine them. # # You can use the \verb+--configure+ command line option (Section~\ref{option:--configure}) to force # re-execution of all the tests. # # \varlabel{OCAMLOPT_EXISTS}{OCAMLOPT\_EXISTS} True when \verb+ocamlopt+ (or \verb+ocamlopt.opt+) is # available on your machine. # \varlabel{OCAMLFIND_EXISTS}{OCAMLFIND\_EXISTS} True when the ocamlfind is available on your # machines. # \varlabel{OCAMLDEP_MODULES_AVAILABLE}{OCAMLDEP\_MODULES\_AVAILABLE} True when a version of # \verb+ocamldep+ that understands the \verb+-modules+ option is available on your machine. # \varlabel{CMXS_SUPPORTED}{CMXS\_SUPPORTED} True if "ocamlopt -shared" is supported by the compiler. # \varlabel{MENHIR_AVAILABLE}{MENHIR\_AVAILABLE} True when the Menhir parser-generator is available # on your machine. # \var{OCAMLLIB} The location of OCaml library directory (output of \verb+ocamlc -where+). Empty when no # ocamlc is found. # # \subsection{Configuration variables for OCaml compilation} # # The following variables can be redefined in your project. # \varlabel{USE_OCAMLFIND}{USE\_OCAMLFIND} Whether to use the \verb+ocamlfind+ utility (default \verb+false+) # \var{OCAMLC} The OCaml bytecode compiler (default \verb+ocamlc.opt+ if it exists # and \verb+USE_OCAMLFIND+ is not set, otherwise \verb+ocamlc+). # \var{OCAMLOPT} The OCaml native-code compiler (default \verb+ocamlopt.opt+ if it # exists and \verb+USE_OCAMLFIND+ is not set, otherwise \verb+ocamlopt+). # \var{CAMLP4} The \verb+camlp4+ preprocessor (default \verb+camlp4+). # \var{OCAMLLEX} The OCaml lexer generator (default \verb+ocamllex+). # \var{OCAMLLEXFLAGS} The flags to pass to \verb+ocamllex+ (default \verb+-q+). # \var{OCAMLYACC} The OCaml parser generator (default \verb+ocamlyacc+). # \var{OCAMLYACCFLAGS} Additional options to pass to \verb+$(OCAMLYACC)+. # \var{OCAMLDEP} The OCaml dependency analyzer (default \verb+ocamldep+). # \varlabel{OCAMLDEP_MODULES_ENABLED}{OCAMLDEP\_MODULES\_ENABLED} Instead of using \verb+OCAMLDEP+ # in a traditional \verb+make+-style fashion, run \verb+$(OCAMLDEP) -modules+ and then # postprocess the output internally to discover all the relevant generated \verb+.ml+ and # \verb+.mli+ files. See Section~\ref{section:ocaml-generated-files} for more information on # interactions between \OMake, \verb+OCAMLDEP+ and generated files. Set to # \verb+$(OCAMLDEP_MODULES_AVAILABLE)+ by default. # \var{OCAMLMKTOP} The OCaml toploop compiler (default \verb+ocamlmktop+). # \var{OCAMLLINK} The OCaml bytecode linker (default \verb+$(OCAMLC)+). # \var{OCAMLOPTLINK} The OCaml native-code linker (default \verb+$(OCAMLOPT)+). # \var{OCAMLINCLUDES} Search path to pass to the OCaml compilers (default \verb+.+). # The search path with the \verb+-I+ prefix is defined by the \verb+PREFIXED_OCAMLINCLUDES+ # variable. # \varlabel{OCAMLINCLUDES_FOR_OCAMLDEP_MODULES}{OCAMLINCLUDES\_FOR\_OCAMLDEP\_MODULES} Extra path for searching files # corresponding to dependencies returned by "ocamldep -modules". This # defaults to ".". There is normally no reason to change this value. # \var{OCAMLFIND} The \verb+ocamlfind+ utility (default \verb+ocamlfind+ if # \verb+USE_OCAMLFIND+ is set, otherwise empty). # \var{OCAMLFINDFLAGS} The flags to pass to \verb+ocamlfind+ (default empty, \verb+USE_OCAMLFIND+ must be set). # \var{OCAMLPACKS} Package names to pass to \verb+ocamlfind+ (\verb+USE_OCAMLFIND+ must be set). # \varlabel{BYTE_ENABLED}{BYTE\_ENABLED} Flag indicating whether to use the bytecode compiler (default \verb+true+, when no \verb+ocamlopt+ found, \verb+false+ otherwise). # \varlabel{NATIVE_ENABLED}{NATIVE\_ENABLED} Flag indicating whether to use the native-code compiler (default \verb+true+, when ocamlopt is found, \verb+false+ otherwise). # Both \verb+BYTE_ENABLED+ and \verb+NATIVE_ENABLED+ can be set to true; # at least one should be set to true. # \varlabel{CMXS_ENABLED}{CMXS\_ENABLED} Flag indicating whether libraries are # also created as plugins. This defaults to \verb+false+ for compatibility # with old omake versions. Set it to \verb+CMXS_SUPPORTED+ to enable this # feature when supported # \varlabel{MENHIR_ENABLED}{MENHIR\_ENABLED} Define this as \verb+true+ if you wish to use # \verb+menhir+ instead of \verb+ocamlyacc+ (default \verb+false+). # \varlabel{EXTENDED_DIGESTS}{EXTENDED\_DIGESTS} Whether to include more information into # rule digests and make it more sensitive to structural changes at the cost # of build speed (\verb+true+ or \verb+false+). # \varlabel{OCAML_CC}{OCAML\_CC} The C compiler used internally by OCaml # \varlabel{OCAML_CFLAGS}{OCAML\_CFLAGS} The C compiler flags used by OCaml # \end{doc} # public.USE_OCAMLFIND = false private.get_c_comp() = # since OCaml-4.06 private.config = $(concat $(unhexify 0a), $(shella ocamlc -config))) private.configch = $(open-in-string $(config)) scan($(configch)) case $"c_compiler:" return $(nth-tl 1, $*) return $(string) private.get_bytecomp_cflags() = # since OCaml-4.06 private.config = $(concat $(unhexify 0a), $(shella ocamlc -config))) private.configch = $(open-in-string $(config)) scan($(configch)) case $"ocamlc_cflags:" return $(nth-tl 1, $*) return $(string) private.get_bytecomp_cppflags() = # since OCaml-4.06 private.config = $(concat $(unhexify 0a), $(shella ocamlc -config))) private.configch = $(open-in-string $(config)) scan($(configch)) case $"ocamlc_cppflags:" return $(nth-tl 1, $*) return $(string) private.get_bytecomp_c_comp() = private.config = $(concat $(unhexify 0a), $(shella ocamlc -config))) private.configch = $(open-in-string $(config)) scan($(configch)) case $"bytecomp_c_compiler:" return $(nth-tl 1, $*) return $(string) .STATIC: :value: $(PATH) OCAMLFIND_EXISTS = $(CheckProg ocamlfind) OCAMLC_OPT_EXISTS = $(CheckProg ocamlc.opt) OCAMLC_EXISTS = $(or $(OCAMLC_OPT_EXISTS), $(CheckProg ocamlc)) OCAMLOPT_OPT_EXISTS = $(CheckProg ocamlopt.opt) OCAMLOPT_EXISTS = $(or $(OCAMLOPT_OPT_EXISTS), $(CheckProg ocamlopt)) OCAMLDEP_OPT_EXISTS = $(CheckProg ocamldep.opt) OCAMLLEX_OPT_EXISTS = $(CheckProg ocamllex.opt) ConfMsgChecking(whether ocamlc understands the "z" warnings) OCAML_ACCEPTS_Z_WARNING = if $(OCAMLC_EXISTS) value $(ConfMsgYesNo $(shell-success-null ocamlc$(if $(OCAMLC_OPT_EXISTS), .opt) -w Az)) else ConfMsgResult($"FAILED - ocamlc not found") value false ConfMsgChecking(whether ocamlopt can create cmxs plugins) CMXS_SUPPORTED = if $(OCAMLOPT_EXISTS) ok = $(ConfMsgYesNo $(shell-success-null ocamlopt -shared -o .dummy.cmxs)) rm(-f .dummy.cmxs) value $(ok) else ConfMsgResult($"no (ocamlopt not found)") value false # # Compile native or byte code? # NATIVE_ENABLED = $(OCAMLOPT_EXISTS) BYTE_ENABLED = $(not $(OCAMLOPT_EXISTS)) CMXS_ENABLED = false # EXTENDED_DIGESTS = false # # Figure out the params for the C compiler # private.c_comp = $(get_c_comp) if $(equal X$(c_comp)X, XX) private.bytecomp_c_comp = $(get_bytecomp_c_comp) OCAML_CC = $(nth-hd 1, $(bytecomp_c_comp)) OCAML_CFLAGS = $(nth-tl 1, $(bytecomp_c_comp)) export OCAML_CC OCAML_CFLAGS else private.bytecomp_cflags = $(get_bytecomp_cflags) private.bytecomp_cppflags = $(get_bytecomp_cppflags) OCAML_CC = $(c_comp) OCAML_CFLAGS = $(bytecomp_cflags) $(bytecomp_cppflags) export OCAML_CC OCAML_CFLAGS public.OCAMLFIND = $`(if $(USE_OCAMLFIND), ocamlfind) public.OCAMLFINDFLAGS = public.LAZY_OCAMLFINDFLAGS = $`(if $(USE_OCAMLFIND), $(OCAMLFINDFLAGS)) # OCAMLC/OCAMLOPT/OCAMLDEP are now 0-ary functions instead of normal variables # because sometimes USE_OCAMLFIND is set too late by the user. public.OCAMLC() = value $(if $(OCAMLC_OPT_EXISTS), $(if $(USE_OCAMLFIND), ocamlc, ocamlc.opt), ocamlc) public.OCAMLOPT() = value $(if $(OCAMLOPT_OPT_EXISTS), $(if $(USE_OCAMLFIND), ocamlopt, ocamlopt.opt), ocamlopt) public.OCAMLDEP() = value $(if $(OCAMLDEP_OPT_EXISTS), $(if $(USE_OCAMLFIND), ocamldep, ocamldep.opt), ocamldep) public.CAMLP4 = camlp4 public.OCAMLLEX = $(if $(OCAMLLEX_OPT_EXISTS), ocamllex.opt, ocamllex) public.OCAMLLEXFLAGS = -q public.OCAMLYACC = ocamlyacc public.OCAMLYACCFLAGS = public.OCAMLMKTOP = ocamlmktop public.OCAMLLINK = $`(OCAMLC) public.OCAMLOPTLINK = $`(OCAMLOPT) .STATIC: :value: $(PATH) OCAMLLIB = if $(OCAMLC_EXISTS) ConfMsgChecking(for OCaml library location) value $(ConfMsgResult $(dir $"$(shell ocamlc -where)")) else value $(EMPTY) # # Include path # public.OCAMLINCLUDES[] = . public.OCAMLINCLUDES_FOR_OCAMLDEP_MODULES[] = . public.PREFIXED_OCAMLINCLUDES = $`(mapprefix -I, $(OCAMLINCLUDES)) # # Packages # public.OCAMLPACKS[] = public.PREFIXED_OCAMLPACKS =\ $`(if $(and $(USE_OCAMLFIND) $(gt $(length $(OCAMLPACKS)), 0)),\ -package $(string $(concat \,, $(OCAMLPACKS))),\ $(EMPTY)) # # Various options # # \begin{doc} # \subsection{OCaml command flags} # # The following variables specify \emph{additional} options to be passed to # the OCaml tools. # \var{OCAMLDEPFLAGS} Flags to pass to \verb+OCAMLDEP+. # \var{OCAMLPPFLAGS} Flags to pass to \verb+CAMLP4+. # \var{OCAMLCFLAGS} Flags to pass to the byte-code compiler (default \verb+-g+). # \var{OCAMLOPTFLAGS} Flags to pass to the native-code compiler (default empty). # \var{OCAMLFLAGS} Flags to pass to either compiler (default \verb+-warn-error A+). # \varlabel{OCAML_BYTE_LINK_FLAGS}{OCAML\_BYTE\_LINK\_FLAGS} Flags to pass to the byte-code linker (default empty). # \varlabel{OCAML_NATIVE_LINK_FLAGS}{OCAML\_NATIVE\_LINK\_FLAGS} Flags to pass to the native-code linker (default empty). # \varlabel{OCAML_LINK_FLAGS}{OCAML\_LINK\_FLAGS} Flags to pass to either linker. # \varlabel{MENHIR_FLAGS}{MENHIR\_FLAGS} Additional flags to pass to \verb+menhir+. # \end{doc} # declare OCAMLDEPFLAGS public.OCAMLPPFLAGS = public.OCAMLFLAGS = public.OCAMLCFLAGS = -g public.OCAMLOPTFLAGS = public.OCAMLCPPFLAGS = public.OCAML_LINK_FLAGS = $`(if $(and $(USE_OCAMLFIND) $(gt $(length $(OCAMLPACKS)), 0)), -linkpkg, $(EMPTY)) public.OCAML_BYTE_LINK_FLAGS = -custom public.OCAML_NATIVE_LINK_FLAGS = # # OCAML_LIBS contains libraries that are used as dependencies # OCAML_OTHER_LIBS contains other libraries (like unix.cma) # The lists do not include suffixes. # # OCAML_LINK_FLAGS contains extra linking information # # \begin{doc} # \subsection{Library variables} # # The following variables are used during linking. # # \varlabel{OCAML_LIBS}{OCAML\_LIBS} Libraries to pass to the linker. These libraries become dependencies # of the link step. # \varlabel{OCAML_OTHER_LIBS}{OCAML\_OTHER\_LIBS} Additional libraries to pass to the linker. These libraries are # \emph{not} included as dependencies to the link step. Typical use is for the OCaml # standard libraries like \verb+unix+ or \verb+str+. # \varlabel{OCAML_CLIBS}{OCAML\_CLIBS} C libraries to pass to the linker. # \varlabel{OCAML_LIB_FLAGS}{OCAML\_LIB\_FLAGS} Extra flags for the library linker. # \varlabel{ABORT_ON_DEPENDENCY_ERRORS}{ABORT\_ON\_DEPENDENCY\_ERRORS} # OCaml linker requires the OCaml files to be # listed in dependency order. Normally, all the functions presented in this section will automatically sort # the list of OCaml modules passed in as the \verb++ argument. However, this variable is # set to \verb+true+, the order of the files passed into these function will be left as is, but \OMake{} will # abort with an error message if the order is illegal. # # \end{doc} # public.OCAML_LIBS = public.OCAML_CLIBS = public.OCAML_OTHER_LIBS = public.OCAML_LIB_FLAGS = ######################################################################## # \begin{doc} # \subsection{Generated OCaml Files} # \label{section:ocaml-generated-files} # As of OCaml version 3.09.2, the standard \verb+ocamldep+ scanner is ``broken''. The main issue is # that it finds only those dependencies that already exist. If \verb+foo.ml+ contains a dependency # on \verb+Bar+, # \begin{verbatim} # foo.ml: # open Bar # \end{verbatim} # then the default \verb+ocamldep+ will only find the dependency if a file \verb+bar.ml+ or # \verb+bar.ml+ exists in the include path. It will not find (or print) the dependency if, for # example, only \verb+bar.mly+ exists at the time \verb+ocamldep+ is run, even though \verb+bar.ml+ # and \verb+bar.mli+ can be generated from \verb+bar.mly+. # # \OMake{} currently provides two methods for addressing this problem --- one that requires manually # specifying the generated files, and an experimental method for discovering such ``hidden'' # dependencies automatically. The # \hypervarx{OCAMLDEP_MODULES_ENABLED}{OCAMLDEP\_MODULES\_ENABLED} controls which method is # going to be used. When this variable is false, the manual specifications are expected and when it # is true, the automated discovery will be attempted. # # \twofuns{OCamlGeneratedFiles}{LocalOCamlGeneratedFiles} # \begin{verbatim} # OCamlGeneratedFiles(files) # LocalOCamlGeneratedFiles(files) # \end{verbatim} # # When the \hypervarx{OCAMLDEP_MODULES_ENABLED}{OCAMLDEP\_MODULES\_ENABLED} variable is set # to \verb+false+, the \verb+OCamlGeneratedFiles+ and \verb+LocalOCamlGeneratedFiles+ functions specify files # that need to be generated before any OCaml files are scanned for dependencies. For example, # if \verb+parser.ml+ and \verb+lexer.ml+ are both generated files, specify: # \begin{verbatim} # OCamlGeneratedFiles(parser.ml lexer.ml) # \end{verbatim} # # The \verb+OCamlGeneratedFiles+ function is \emph{global} --- its arguments will be generated # before any OCaml files anywhere in the project are scanned for dependencies. The # \verb+LocalOCamlGeneratedFiles+ function follows the normal scoping rules of OMake. # # These functions have no effect when the # \hypervarx{OCAMLDEP_MODULES_ENABLED}{OCAMLDEP\_MODULES\_ENABLED} is true. # # \subsubsection{Automatic discovery of generated files during dependency analysis} # Having to specify the generated files manualy when \OMake{} could discover them automatically is # obviously suboptimal. To address this, we tell \verb+ocamldep+ to \emph{only} # find the free module names in a file and then post-process the results internally. # # This automated functionality is enabled when the # \hypervarx{OCAMLDEP_MODULES_ENABLED}{OCAMLDEP\_MODULES\_ENABLED} is set to \verb+true+. # By default, \hypervarx{OCAMLDEP_MODULES_ENABLED}{OCAMLDEP\_MODULES\_ENABLED} will be set to # \verb+$(OCAMLDEP_MODULES_AVAILABLE)+. # # Note that the \verb+ocamldep+ functionality this relies upon is only included in # the OCaml version 3.10 and higher. It's availability will be discovered automatically # and the \hypervarx{OCAMLDEP_MODULES_AVAILABLE}{OCAMLDEP\_MODULES\_AVAILABLE} # will be set accordingly. # # \end{doc} # .STATIC: ConfMsgChecking(if ocamldep understands -modules) OCAMLDEP_MODULES_AVAILABLE = $(ConfMsgYesNo $(shell-success-null ocamldep -modules)) public.OCAMLDEP_MODULES_ENABLED = $(OCAMLDEP_MODULES_AVAILABLE) public.OCAMLDEPFLAGS = $`(if $(and $(NATIVE_ENABLED), $(not $(OCAMLDEP_MODULES_ENABLED))), -native, $(EMPTY)) .PHONY: OCamlGeneratedFilesTarget # GS: The test on $(OCAMLDEP_MODULES_ENABLED) in only partially working. # What if we set this variable later? public.OCamlGeneratedFiles(files) = if $(OCAMLDEP_MODULES_ENABLED) # For now, we want to allow ``backwards-compatible'' projects. # eprintln($"WARNING: OCamlGeneratedFiles should not be used when OCAMLDEP_MODULES_ENABLED") # eprintln($" is set") else OCamlGeneratedFilesTarget: $(files) public.LocalOCamlGeneratedFiles(files) = if $(OCAMLDEP_MODULES_ENABLED) # For now, we want to allow ``backwards-compatible'' projects. # eprintln($"WARNING: OCamlGeneratedFiles should not be used when OCAMLDEP_MODULES_ENABLED") # eprintln($" is set") else .SCANNER: scan-ocaml-%: $(files) .SCANNER: %.cmi: $(files) .SCANNER: %.cmx %.cmo: $(files) export export # # The ocamldep -modules output has the following # form, where the indented lines are the free module names in foo.ml. # # foo.ml: # Bar # ... # # From this, we generate proper dependencies by finding the files # that can be built, using the find-targets-in-path-optional # function. # # # Print the dependencies for a ML file, based on the # .cmi files. # # If OCAMLDEP_PRESERVE_TARGETS is true, then the # ocamldep entries are taken literally (the suffix # is not replaced with .cmo/.cmx). # public.OCAMLDEP_PRESERVE_TARGETS = false public.PrintMLIDependencies(filename, cmideps) = if $(cmideps) private.base = $(string-escaped $(removesuffix $(filename))) println($"""$(base).cmi: $(string-escaped $(cmideps))""") public.PrintMLDependencies(filename, cmideps, cmxdeps) = protected.base = $(string-escaped $(removesuffix $(filename))) protected.esc = $' \' protected.text = if $(cmideps) cmideps = $(string-escaped $(cmideps)) text = $""" $(base).cmo: $(cmideps) $(base).cmx $(base)$(EXT_OBJ):$(esc) $(cmideps)""" export text if $(cmxdeps) if $(not $(text)) text = $"""$(base).cmx $(base)$(EXT_OBJ):""" export text += $"""$(esc) $(string-escaped $(cmxdeps))""" export text # eprintln($(text)) println($(text)) public.PrintFileDependencies(filename, cmideps) = if $(cmideps) private.text = $"""$(string-escaped $(filename)): $(string-escaped $(cmideps))""" # eprintln($(text)) println($(text)) # # Given a set of literal dependencies, compute # the actual dependencies by finding the filenames # associated with each module. # public.PrintDependencies(filename, modules) = private.includes[] = $(OCAMLINCLUDES_FOR_OCAMLDEP_MODULES) $(OCAMLINCLUDES) if $(filename) # # Find the .cmi files that can be built # private.cmideps = $(find-ocaml-targets-in-path-optional $(includes), $(addsuffix .cmi, $(modules))) # Now produce the dependencies if $(OCAMLDEP_PRESERVE_TARGETS) PrintFileDependencies($(filename), $(cmideps)) else switch($(suffix $(filename))) case .ml protected.cmxdeps[] = if $(NATIVE_ENABLED) cmxdeps = $(find-ocaml-targets-in-path-optional $(includes), $(addsuffix .cmx, $(modules))) export PrintMLDependencies($(filename), $(cmideps), $(cmxdeps)) case .mli PrintMLIDependencies($(filename), $(cmideps)) default eprintln($"ocaml scanner: illegal filename $(filename)") exit(1) # # Post-process the output of ocamldep. # Use awk to process the input, find the targets that # exist, and then print the dependencies. # public.OCamlScannerPostproc(input) = # # Read the module names from the standard input # protected.filename = protected.modules[] = awk(b, $(input)) case $'^\(.*\):[[:space:]]*\(.*\)$' PrintDependencies($(filename), $(modules)) filename = $1 modules[] = $(split $' ', $2) export case $'^ \(.*\)' # Add the dependency modules[] += $1 export default eprintln(Unrecognized ocamldep output: $0) PrintDependencies($(filename), $(modules)) Shell. += ocamldep-postproc(argv) = if $(defined ocamldep-postproc) ocamldep-postproc($(OCAMLINCLUDES_FOR_OCAMLDEP_MODULES) $(OCAMLINCLUDES), $(NATIVE_ENABLED)) else OCamlScannerPostproc($(stdin)) Shell. += ocamldep-postproc-preserve(argv) = OCAMLDEP_PRESERVE_TARGETS = true OCamlScannerPostproc($(stdin)) public.OCamlScanner(src_file) = if $(OCAMLDEP_MODULES_ENABLED) value $(OCAMLFIND) $(OCAMLDEP) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLDEPFLAGS) -modules $(src_file) | ocamldep-postproc else value $(OCAMLFIND) $(OCAMLDEP) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLDEPFLAGS) $(PREFIXED_OCAMLINCLUDES) $(src_file) ######################################################################## # Generic build rules. # # The order of the %.cmi rules is important. # The most recent definition is used first, if it applies. # 1. The .cmi is generated from the .mli, if it exists # 2. Otherwise it is generated from the .ml # # In case 2, make sure to use the same command text that is used for # generating the .cmo or .cmx file. This will prevent the compiler # from being called twice: once to generate the .cmi file, and again # for the .cmo or .cmx file. # public.OCamlC() = value $(OCAMLFIND) $(OCAMLC) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS)\ $(OCAMLCFLAGS) $(OCAMLPPFLAGS) $(PREFIXED_OCAMLINCLUDES) public.OCamlOpt() = value $(OCAMLFIND) $(OCAMLOPT) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS)\ $(OCAMLOPTFLAGS) $(OCAMLPPFLAGS) $(PREFIXED_OCAMLINCLUDES) %.cmx: %.ml section rule if $(not $(NATIVE_ENABLED)) err. = extends $(UnbuildableException) message = $(string $"You are trying to build OCaml native code file: "%.cmx$" However, the NATIVE_ENABLED flag is not set. Include the following definition in your OMakefile if you really want to build this file. NATIVE_ENABLED = true") target = $(file %.cmx) raise $(err) elseif $(target-exists %.mli) %.cmx %$(EXT_OBJ): %.ml %.cmi :scanner: scan-ocaml-%.ml $(OCamlOpt) -c $< elseif $(BYTE_ENABLED) %.cmx %.cmi %$(EXT_OBJ) %.cmo: %.ml :scanner: scan-ocaml-%.ml $(OCamlC) -c $< $(OCamlOpt) -c $< else %.cmx %.cmi %$(EXT_OBJ): %.ml :scanner: scan-ocaml-%.ml $(OCamlOpt) -c $< %$(EXT_OBJ): %.ml section rule if $(not $(NATIVE_ENABLED)) err. = extends $(UnbuildableException) message = $(string $"You are trying to build OCaml native code file: "%$(EXT_OBJ)$" However, the NATIVE_ENABLED flag is not set. Include the following definition in your OMakefile if you really want to build this file. NATIVE_ENABLED = true") target = $(file %.cmx) raise $(err) elseif $(target-exists %.mli) %$(EXT_OBJ) %.cmx: %.ml %.cmi :scanner: scan-ocaml-%.ml $(OCamlOpt) -c $< elseif $(BYTE_ENABLED) %$(EXT_OBJ) %.cmi %.cmx %.cmo: %.ml :scanner: scan-ocaml-%.ml $(OCamlC) -c $< $(OCamlOpt) -c $< else %$(EXT_OBJ) %.cmi %.cmx: %.ml :scanner: scan-ocaml-%.ml $(OCamlOpt) -c $< # This is an experimental rule %.i.mli: %.ml section rule %.i.mli: %.ml %.cmi :scanner: scan-ocaml-%.ml $(OCamlC) -i -c %.ml > $@ %.cmo: %.ml section rule if $(not $(BYTE_ENABLED)) err. = extends $(UnbuildableException) message = $(string $"You are trying to build OCaml native code file: "%.cmo$" However, the BYTE_ENABLED flag is not set. Include the following definition in your OMakefile if you really want to build this file. BYTE_ENABLED = true") target = $(file %.cmx) raise $(err) elseif $(target-exists %.mli) %.cmo: %.ml %.cmi :scanner: scan-ocaml-%.ml $(OCamlC) -c $< elseif $(NATIVE_ENABLED) %.cmo %.cmi %.cmx %$(EXT_OBJ): %.ml :scanner: scan-ocaml-%.ml $(OCamlC) -c $< $(OCamlOpt) -c $< else %.cmo %.cmi: %.ml :scanner: scan-ocaml-%.ml $(OCamlC) -c $< %.cmi: %.ml section rule if $(BYTE_ENABLED) if $(NATIVE_ENABLED) %.cmi %.cmo %.cmx %$(EXT_OBJ): %.ml :scanner: scan-ocaml-%.ml $(OCamlC) -c $< $(OCamlOpt) -c $< else %.cmi %.cmo: %.ml :scanner: scan-ocaml-%.ml $(OCamlC) -c $< else %.cmi %.cmx %$(EXT_OBJ): %.ml :scanner: scan-ocaml-%.ml $(OCamlOpt) -c $< %.cmi: %.mli :scanner: scan-ocaml-%.mli $(OCamlC) -c $< # \begin{doc} # \fun{DeclareMLIOnly} # # Sometimes, MLI files only contain type and exception definitions. In fact, # the MLI file could also be parsed as ML file. For convenience, it is possible # to declare modules as MLI-only. In this case, an ML file needs not to be # written. Do this as follows: # # \verb+DeclareMLIOnly()+ # # where the \verb++ are without suffixes. # # Note that this really only works if the MLI file can be parsed as ML file. # Also, it is possible this results in an object to be linked in, so don't # forget to link the modules into the library or executable. # \end{doc} DeclareMLIOnly(modules) = foreach(mod => ..., $(modules)) if $(BYTE_ENABLED) if $(NATIVE_ENABLED) $(mod).cmi $(mod).cmo $(mod).cmx $(mod).o: $(mod).mli $(OCamlC) -c $(mod).mli $(OCamlC) -c -impl $(mod).mli $(OCamlOpt) -c -impl $(mod).mli else $(mod).cmi $(mod).cmo: $(mod).mli $(OCamlC) -c $(mod).mli $(OCamlC) -c -impl $(mod).mli else $(mod).cmi $(mod).cmx $(mod).o: $(mod).mli $(OCamlC) -c $(mod).mli $(OCamlOpt) -c -impl $(mod).mli ######################################################################## # Parser generators # # # You can choose to use ocamlyacc or menhir for a parser # generator. The default is ocamlyacc. Define the # MENHIR_ENABLED as true if you would rather use menhir. # # Variables: # MENHIR : the name of the menhir executable # MENHIR_FLAGS : any additional options to pass to Menhir # MENHIR_AVAILABLE : the menhir executable is installed # MENHIR_RAW_DEPEND : menhir supports the --raw-depend option # public.MENHIR = menhir public.MENHIR_FLAGS = public.MENHIR_ENABLED = false .STATIC: MENHIR_AVAILABLE = $(CheckProg $(MENHIR)) MENHIR_RAW_DEPEND = false if $(MENHIR_AVAILABLE) ConfMsgChecking(if $(MENHIR) supports the --raw-depend option) MENHIR_RAW_DEPEND = $(ConfMsgYesNo $(shell-success-null $(MENHIR) -help | grep $'^ *--raw-depend')) export # Menhir is being requested. Check that it is installed. public.MenhirCheck() = if $(not $(MENHIR_AVAILABLE)) eprintln($"""!!! You are asking to use Menhir, but it is not installed.""") eprintln($"""!!! See the Menhir home page for instructions on downloading.""") eprintln($"""!!! http://cristal.inria.fr/~fpottier/menhir/""") exit(1) # Compute the correct ocamlc and ocamldep options for Menhir. public.MenhirOCamlcCommand() = MenhirCheck() private.ocamlc[] =\ $(OCAMLFIND) $(OCAMLC) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS)\ $(OCAMLCFLAGS) $(OCAMLPPFLAGS) $(PREFIXED_OCAMLINCLUDES) value --ocamlc $(quote-argv $(ocamlc)) public.MenhirOCamldepCommand(raw) = ocamldep = if $(raw) value $(OCAMLDEP) -modules $(OCAMLDEPFLAGS) else value $(OCAMLDEP) $(PREFIXED_OCAMLINCLUDES) $(OCAMLDEPFLAGS) value --ocamldep $(quote-argv $(ocamldep)) # Compute the Mendir dependency scanner command public.MenhirScannerCommand(base, src) = if $(MENHIR_ENABLED) if $(and $(MENHIR_RAW_DEPEND), $(OCAMLDEP_MODULES_ENABLED)) value $(MENHIR) $(MENHIR_FLAGS) $(MenhirOCamldepCommand true) $(base) --raw-depend $(src) | ocamldep-postproc-preserve else value $(MENHIR) $(MENHIR_FLAGS) $(MenhirOCamldepCommand false) $(base) --depend $(src) # Use Menhir if MENHIR_ENABLED, ocamlyacc otherwise public.OCamlYaccCommand(src) = if $(MENHIR_ENABLED) value $(MENHIR) $(MENHIR_FLAGS) $(MenhirOCamlcCommand) $(src) else value $(OCAMLYACC) $(OCAMLYACCFLAGS) $(src) .SCANNER: scan-ocamlyacc-%.mly: %.mly :value: $(MENHIR_ENABLED) $(OCamlScannerTargets $&) $(MenhirScannerCommand $(EMPTY), $<) %.ml %.mli: %.mly :scanner: scan-ocamlyacc-%.mly $(OCamlYaccCommand $<) # # \begin{doc} # \subsection{Using the Menhir parser generator} # # Menhir is a parser generator that is mostly compatible with # \verb+ocamlyacc+, but with many improvements. A few of these # are listed here (excerpted from the Menhir home page # \url{http://cristal.inria.fr/~fpottier/menhir/}). # # \begin{itemize} # \item Menhir's explanations are believed to be understandable by mere humans. # \item Menhir allows grammar specifications to be split over multiple files. # It also allows several grammars to share a single set of tokens. # \item Menhir is able to produce parsers that are parameterized by Objective Caml modules. # \item [Added by jyh] With the \verb+--infer+ option, Menhir can typecheck the semantic actions # in your grammar at \emph{generation} time. # \end{itemize} # # What do you need to do to use Menhir instead of \verb+ocamlyacc+? # \begin{enumerate} # \item Place the following definition before the relevant section of your project # (or at the top of your project \verb+OMakefile+ if you want to use Menhir everywhere). # # \begin{verbatim} # MENHIR_ENABLED = true # \end{verbatim} # # \item Optionally, add any desired Menhir options to the \verb+MENHIR_FLAGS+ variable. # # \begin{verbatim} # MENHIR_FLAGS += --infer # \end{verbatim} # \end{enumerate} # # With this setup, any file with a \verb+.mly+ suffix will be compiled with Menhir. # # If your grammar is split across several files, you need to specify it explicitly, # using the \verb+MenhirMulti+ function. # # \begin{verbatim} # MenhirMulti(target, sources) # target : filename, without suffix # sources : the files that define the grammar, without suffixes # \end{verbatim} # # For example, if you want to generate the parser files \verb+parse.ml+ and \verb+parse.mli+, # from the grammar specified in files \verb+a.mly+ and \verb+b.mly+, you would use # the following. # # \begin{verbatim} # MenhirMulti(parse, a b) # \end{verbatim} # \end{doc} # public.MenhirMulti(target, sources) = MenhirCheck() sources = $(addsuffix .mly, $(sources)) # Menhir needs all the files for dependency analysis .SCANNER: scan-menhir-$(target).multi: $(sources) :value: $(OCamlScannerTargets $&) $(MenhirScannerCommand --base $(target), $+) # Set up the actual rule $(target).ml $(target).mli: $(sources) :scanner: scan-menhir-$(target).multi $(MENHIR) $(MENHIR_FLAGS) $(MenhirOCamlcCommand) --base $(target) $+ ######################################################################## # Other common generated files # %.ml %.mli: %.mlz ln-or-cp $< $*.ml ln-or-cp $< $*.mli %.ml: %.mll $(OCAMLLEX) $(OCAMLLEXFLAGS) $< %.ml: %.mlp %.h @rm -f $@ @echo "(* CAUTION: this is a generated file. If you edit it, all changes will be lost! *)" > $@ $(CPP) $(OCAMLCPPFLAGS) -imacros $*.h $*.mlp >> $@ @chmod 444 $@ # # Generic scanners # OCamlScannerTargetsExtended(files) = files[] = $(basename $(files)) files[] = $(if $(NATIVE_ENABLED), $(files), $(filter-out %.cmx, $(files))) files[] = $(if $(BYTE_ENABLED), $(files), $(filter-out %.cmo, $(files))) value $(find-targets-in-path-optional $(OCAMLINCLUDES), $(files)) $(NATIVE_ENABLED) $(BYTE_ENABLED) OCamlScannerTargetsSimplified(dummy) = value $(NATIVE_ENABLED) $(BYTE_ENABLED) if $(EXTENDED_DIGESTS) OCamlScannerTargets = $(OCamlScannerTargetsExtended) export else OCamlScannerTargets = $(OCamlScannerTargetsSimplified) export .SCANNER: scan-ocaml-%.mli: %.mli /.PHONY/OCamlGeneratedFilesTarget :value: $(OCamlScannerTargets $&) $(OCamlScanner $<) .SCANNER: scan-ocaml-%.ml: %.ml /.PHONY/OCamlGeneratedFilesTarget :exists: %.mli :value: $(OCamlScannerTargets $&) $(OCamlScanner $<) # # Default .SCANNER rules for backwards-compatibility. # .SCANNER: %.cmi: %.mli /.PHONY/OCamlGeneratedFilesTarget :value: $(OCamlScannerTargets $&) $(OCamlScanner $<) .SCANNER: %.cmx %.cmo %$(EXT_OBJ): %.ml /.PHONY/OCamlGeneratedFilesTarget :exists: %.mli :value: $(OCamlScannerTargets $&) $(OCamlScanner $<) # # Define a link order for OCaml files. # If a file depends on a %.cmi, it also depends on %.cmo # .ORDER: .OCAMLLINK .OCAMLLINK: %.cmi: %.cmo .OCAMLLINK: %.cmx: %.cmo public.ABORT_ON_DEPENDENCY_ERRORS = false OCamlLinkSort(nodes) = if $(ABORT_ON_DEPENDENCY_ERRORS) value $(file-check-sort .OCAMLLINK, $(nodes)) else value $(file-sort .OCAMLLINK, $(nodes)) # # Generic rule to build an ML library # # \begin{doc} # \fun{OCamlLibrary} # # The \verb+OCamlLibrary+ function builds an OCaml library. # # \verb+OCamlLibrary(, )+ # # The \verb++ and \verb++ are listed \emph{without} suffixes. # # This function returns the list of all the targets that it defines the rules # for (including the \verb+$(name)$(EXT_LIB)+ file when \verb+NATIVE_ENABLED+ is set). # # The following code builds the \verb+libfoo.cmxa+ library from the files \verb+foo.cmx+ # and \verb+bar.cmx+ (if \verb+NATIVE_ENABLED+ is set), and \verb+libfoo.cma+ from # \verb+foo.cmo+ and \verb+bar.cmo+ (if \verb+BYTE_ENABLED+ is set). # # \begin{verbatim} # OCamlLibrary(libfoo, foo bar) # \end{verbatim} # # If the variable \verb+CMXS_ENABLED+ is set, additionally the cmxs plugin # is created. Note that \verb+CMXS_SUPPORTED+ returns whether the compiler # installation supports plugins, so you can simply set # # \begin{verbatim} # CMXS_ENABLED = CMXS_SUPPORTED # \end{verbatime} # # before calling \verb+OCamlLibrary+. For compatibility with older omake # versions, \verb+CMXS_ENABLED+ defaults to \verb+false+. # \end{doc} # public.OCamlLibrary(name, files) = # XXX: JYH: these variables should be marked private in 0.9.9 protected.name = $(file $(name)) protected.OFILES = $(addsuffix $(EXT_OBJ), $(files)) protected.CMOFILES = $(addsuffix .cmo, $(files)) protected.CMXFILES = $(addsuffix .cmx, $(files)) protected.CLIB = $(file $(name)$(EXT_LIB)) protected.BYTELIB = $(file $(name).cma) protected.NATIVELIB = $(file $(name).cmxa) protected.SHAREDLIB = $(file $(name).cmxs) # # Link commands # $(BYTELIB): $(CMOFILES) $(OCAMLFIND) $(OCAMLLINK) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) $(OCAMLCFLAGS) \ $(OCAML_LIB_FLAGS) -a -o $@ $(OCamlLinkSort $(CMOFILES)) $(NATIVELIB) $(CLIB): $(CMXFILES) $(OFILES) $(OCAMLFIND) $(OCAMLOPTLINK) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ $(OCAML_LIB_FLAGS) -a -o $(NATIVELIB) $(OCamlLinkSort $(CMXFILES)) $(SHAREDLIB): $(NATIVELIB) $(CLIB) $(OCAMLFIND) $(OCAMLOPTLINK) -shared -cclib -L. -o $(SHAREDLIB) $(NATIVELIB) return $(array $(if $(NATIVE_ENABLED), $(NATIVELIB)), $(if $(NATIVE_ENABLED), $(CLIB)), $(if $(BYTE_ENABLED), $(BYTELIB)), $(if $(CMXS_ENABLED), $(SHAREDLIB))) # # Generic rule to build an ML library # # \begin{doc} # \fun{OCamlPackage} # # The \verb+OCamlPackage+ function builds an OCaml package. # # \verb+OCamlPackage(, )+ # # The \verb++ and \verb++ are listed \emph{without} suffixes. # The \verb++ must have been compiled with the \verb+-for-pack + # flag to the OCaml compiler. # # This function returns the list of all the targets that it defines the rules # for (including the \verb+$(name)$(EXT_LIB)+ file when \verb+NATIVE_ENABLED+ is set). # # The following code builds the \verb+libfoo.cmx+ package from the files \verb+package.cmx+ # and \verb+bar.cmx+ (if \verb+NATIVE_ENABLED+ is set), and \verb+package.cmo+ from # \verb+foo.cmo+ and \verb+bar.cmo+ (if \verb+BYTE_ENABLED+ is set). # # \begin{verbatim} # OCamlPackage(package, foo bar) # \end{verbatim} # \end{doc} # public.OCamlPackage(name, files) = # XXX: JYH: these variables should be marked private in 0.9.9 protected.OFILES = $(addsuffix $(EXT_OBJ), $(files)) protected.CMOFILES = $(addsuffix .cmo, $(files)) protected.CMXFILES = $(addsuffix .cmx, $(files)) protected.OBJ = $(file $(name)$(EXT_OBJ)) protected.CMO = $(file $(name).cmo) protected.CMX = $(file $(name).cmx) protected.CMI = $(file $(name).cmi) protected.MLI = $(file $(name).mli) protected.BYTE_TARGETS = $(CMO) protected.NATIVE_TARGETS = $(CMX) $(OBJ) protected.BYTE_DEPS = $(CMOFILES) protected.NATIVE_DEPS = $(CMXFILES) $(OFILES) # note that always returning $(CMI) is slightly incorrect, but we cannot # do it better protected.TARGETS = $(CMI) if $(NATIVE_ENABLED) TARGETS += $(NATIVE_TARGETS) export if $(BYTE_ENABLED) TARGETS += $(BYTE_TARGETS) export BYTE_CMD = $(OCAMLFIND) $(OCAMLC) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) \ $(OCAMLCFLAGS) $(OCAML_LIB_FLAGS) -pack -o $(CMO) $`(OCamlLinkSort $(CMOFILES)) NATIVE_CMD = $(OCAMLFIND) $(OCAMLOPTLINK) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) \ $(OCAMLOPTFLAGS) $(OCAML_LIB_FLAGS) -pack -o $(CMX) $`(OCamlLinkSort $(CMXFILES)) # # Link commands # # NB. we use here section rules because we want to evaluate target-exists # first when the build has started, and not NOW. The target could be # defined later. if $(and $(BYTE_ENABLED), $(NATIVE_ENABLED)) $(BYTE_TARGETS): section rule if $(target-exists $(MLI)) $(BYTE_TARGETS): $(BYTE_DEPS) $(CMI) $(BYTE_CMD) else $(BYTE_TARGETS) $(CMI): $(BYTE_DEPS) $(BYTE_CMD) $(NATIVE_TARGETS): section rule if $(target-exists $(MLI)) $(NATIVE_TARGETS): $(NATIVE_DEPS) $(CMI) $(NATIVE_CMD) else $(NATIVE_TARGETS): $(NATIVE_DEPS) $(CMI) $(NATIVE_CMD) -intf-suffix .cmi $(CMI): section rule if $(target-exists $(MLI)) $(CMI): $(MLI) else $(BYTE_TARGETS) $(CMI): $(BYTE_DEPS) $(BYTE_CMD) elseif $(BYTE_ENABLED) $(BYTE_TARGETS): section rule if $(target-exists $(MLI)) $(BYTE_TARGETS): $(BYTE_DEPS) $(CMI) $(BYTE_CMD) else $(BYTE_TARGETS) $(CMI): $(BYTE_DEPS) $(BYTE_CMD) $(CMI): section rule if $(target-exists $(MLI)) $(CMI): $(MLI) else $(BYTE_TARGETS) $(CMI): $(BYTE_DEPS) $(BYTE_CMD) elseif $(NATIVE_ENABLED) $(NATIVE_TARGETS): section rule if $(target-exists $(MLI)) $(NATIVE_TARGETS): $(NATIVE_DEPS) $(CMI) $(NATIVE_CMD) else $(NATIVE_TARGETS) $(CMI): $(NATIVE_DEPS) $(NATIVE_CMD) $(CMI): section rule if $(target-exists $(MLI)) $(CMI): $(MLI) else $(NATIVE_TARGETS) $(CMI): $(NATIVE_DEPS) $(NATIVE_CMD) return $(TARGETS) # # If the interfaces are to be installed, # define this variable to be true. # public.INSTALL_INTERFACES = false # # Install the library # # \begin{doc} # \fun{OCamlLibraryCopy} # # The \verb+OCamlLibraryCopy+ function copies a library to an install location. # # \verb+OCamlLibraryCopy(, , , )+ # # The \verb++ specify additional interface files # to be copied if the \verb+INSTALL_INTERFACES+ variable is true. # \end{doc} # public.OCamlLibraryCopy(tag, lib, name, ifiles) = # # Copy interfaces # if $(INSTALL_INTERFACES) private.MLIFILES = $(filter-targets $(addsuffix .mli, $(ifiles))) private.CMIFILES = $(addsuffix .cmi, $(ifiles)) foreach(src => ..., $(MLIFILES) $(CMIFILES)) $(lib)/$(basename $(src)): $(src) $(lib) :scanner: $(NOSCANNER) ln-or-cp $< $@ # Add to the install tag $(tag): $(file $(addprefix $(lib)/, $(basename $(MLIFILES) $(CMIFILES)))) # # Also install libraries # private.CLIB = $(file $(name)$(EXT_LIB)) private.BYTELIB = $(file $(name).cma) private.NATIVELIB = $(file $(name).cmxa) private.LIBCLIB = $(file $(lib)/$(name)$(EXT_LIB)) private.LIBBYTE = $(file $(lib)/$(name).cma) private.LIBNATIVE = $(file $(lib)/$(name).cmxa) # # Link libraries into lib directory # $(LIBBYTE): $(BYTELIB) ln-or-cp $< $@ $(LIBNATIVE): $(NATIVELIB) ln-or-cp $< $@ $(LIBCLIB): $(CLIB) ln-or-cp $< $@ # # Add dependencies to the target tag # public.FILES[] = if $(BYTE_ENABLED) FILES[] += $(LIBBYTE) export if $(NATIVE_ENABLED) FILES[] += $(LIBNATIVE) $(LIBCLIB) export $(tag): $(FILES) return $(FILES) # # We often use them together # # \begin{doc} # \fun{OCamlLibraryInstall} # # The \verb+OCamlLibraryInstall+ function builds a library # and copies it to an install location in one step. # # \verb+OCamlLibraryInstall(, , , )+ # \end{doc} # public.OCamlLibraryInstall(tag, lib, name, files) = OCamlLibrary($(name), $(files)) return $(OCamlLibraryCopy $(tag), $(lib), $(name), $(files)) # # Generic rule to build an OCaml program # name: the name of the target, without a suffix # files: names of the object files, without suffixes # # Other variables: # OCAML_LIBS: OCaml libraries target depends on, without suffix # OCAML_CLIBS: C libraries we depend on, without suffix # OCAML_OTHER_LIBS: OCaml libraries, without dependencies, without suffix # OCAML_BYTE_LINK_FLAGS: additional flags for byte compiler # OCAML_NATIVE_LINK_FLAGS: additional flags for native-code compiler # OCAML_LINK_FLAGS: general additional options (usually the -cclib options) # # \begin{doc} # \fun{OCamlProgram} # # The \verb+OCamlProgram+ function builds an OCaml program. It returns the array with all # the targets for which it has defined the rules (\verb+$(name)$(EXE)+ and \verb+$(name).run+ # and/or \verb+$(name).opt+, depending on the \verb+NATIVE_ENABLED+ and \verb+BYTE_ENABLED+ # variables). # # \verb+OCamlProgram(, )+ # # Additional variables used: # \begin{description} # \item[\hypervarxn{OCAML_LIBS}{OCAML\_LIBS}] Additional libraries passed to the linker, without suffix. These files # become dependencies of the target program. # \item[\hypervarxn{OCAML_OTHER_LIBS}{OCAML\_OTHER\_LIBS}] Additional libraries passed to the linker, without suffix. These # files do \emph{not} become dependencies of the target program. # \item[\hypervarxn{OCAML_CLIBS}{OCAML\_CLIBS}] C libraries to pass to the linker. # \item[\hypervarxn{OCAML_BYTE_LINK_FLAGS}{OCAML\_BYTE\_LINK\_FLAGS}] Flags to pass to the bytecode linker. # \item[\hypervarxn{OCAML_NATIVE_LINK_FLAGS}{OCAML\_NATIVE\_LINK\_FLAGS}] Flags to pass to the native code linker. # \item[\hypervarxn{OCAML_LINK_FLAGS}{OCAML\_LINK\_FLAGS}] Flags to pass to both linkers. # \end{description} # \end{doc} # public.OCamlProgram(name, files) = # XXX: JYH: these variables should be marked private in 0.9.9 protected.CMOFILES = $(addsuffix .cmo, $(files)) protected.CMXFILES = $(addsuffix .cmx, $(files)) protected.OFILES = $(addsuffix $(EXT_OBJ), $(files)) protected.CMAFILES = $(addsuffix .cma, $(OCAML_LIBS)) protected.CMXAFILES = $(addsuffix .cmxa, $(OCAML_LIBS)) protected.ARFILES = $(addsuffix $(EXT_LIB), $(OCAML_LIBS)) protected.CMA_OTHER_FILES = $(addsuffix .cma, $(OCAML_OTHER_LIBS)) protected.CMXA_OTHER_FILES = $(addsuffix .cmxa, $(OCAML_OTHER_LIBS)) protected.CLIBS = $(addsuffix $(EXT_LIB), $(OCAML_CLIBS)) protected.name = $(file $(name)) protected.PROG = $(file $(name)$(EXE)) protected.BYTEPROG = $(file $(name).run) protected.OPTPROG = $(file $(name).opt) # # Rules to build byte-code and native targets # $(BYTEPROG): $(CMAFILES) $(CMOFILES) $(CLIBS) $(OCAMLFIND) $(OCAMLLINK) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) $(OCAMLCFLAGS)\ $(PREFIXED_OCAMLINCLUDES) $(OCAML_BYTE_LINK_FLAGS)\ -o $@ $(CMA_OTHER_FILES) $(CMAFILES) $(OCamlLinkSort $(CMOFILES))\ $(CLIBS) $(OCAML_LINK_FLAGS) $(OPTPROG): $(CMXAFILES) $(ARFILES) $(CMXFILES) $(OFILES) $(CLIBS) $(OCAMLFIND) $(OCAMLOPTLINK) $(LAZY_OCAMLFINDFLAGS) $(PREFIXED_OCAMLPACKS) $(OCAMLFLAGS) $(OCAMLOPTFLAGS)\ $(PREFIXED_OCAMLINCLUDES) $(OCAML_NATIVE_LINK_FLAGS)\ -o $@ $(CMXA_OTHER_FILES) $(CMXAFILES) $(OCamlLinkSort $(CMXFILES))\ $(CLIBS) $(OCAML_LINK_FLAGS) # # Link the actual executables. # Always prefer native executables. # if $(NATIVE_ENABLED) $(PROG): $(OPTPROG) ln-or-cp $< $@ else $(PROG): $(BYTEPROG) ln-or-cp $< $@ return $(array $(PROG), $(if $(NATIVE_ENABLED), $(OPTPROG)), $(if $(BYTE_ENABLED), $(BYTEPROG))) # # Copy to $(BIN) directory # # \begin{doc} # \fun{OCamlProgramCopy} # # The \verb+OCamlProgramCopy+ function copies an OCaml program to an install location. # # \verb+OCamlProgramCopy(, , )+ # # Additional variables used: # \begin{description} # \item[NATIVE\_ENABLED] If the \hypervarx{NATIVE_ENABLED}{NATIVE\_ENABLED} is set, the native-code executable # is copied; otherwise the byte-code executable is copied. # \end{description} # \end{doc} # public.OCamlProgramCopy(tag, bin, name) = private.name = $(file $(name)) private.BYTEPROG = $(file $(name).run) private.OPTPROG = $(file $(name).opt) private.SRCNAME = $(if $(NATIVE_ENABLED), $(OPTPROG), $(BYTEPROG)) private.BINNAME = $(file $(bin)/$(basename $(name))$(EXE)) # # Link the actual executables. # Always prefer native executables. # $(BINNAME): $(SRCNAME) $(bin) ln-or-cp $< $@ # Add to phony tag. $(tag): $(BINNAME) return $(BINNAME) # # We often use them together # # \begin{doc} # \fun{OCamlProgramInstall} # # The \verb+OCamlProgramInstall+ function builds a programs and copies it to # an install location in one step. # # \verb+OCamlProgramInstall(, , , )+ # \end{doc} # public.OCamlProgramInstall(tag, bin, name, files) = OCamlProgram($(name), $(files)) return $(OCamlProgramCopy $(tag), $(bin), $(name)) # vim:tw=100:fo=tcq: omake-0.10.3/lib/build/LaTeX.om0000644000175000017500000003623713177364666014530 0ustar gerdgerd######################################################################## # Building LaTeX documents. # # Copyright (C) 2003-2007 Jason Hickey and Mojave Group # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. open build/Common ######################################################################## # LaTeX Section # # # LaTeX config # # \begin{doc} # \section{Building \LaTeX\ files} # # \OMake{} provides support for building \LaTeX\ documents, including support for automatically # running BiBTex and for producing PostScript and PDF files. In order to use the functions # defined in this section, you need to make sure the line # \begin{verbatim} # open build/LaTeX # \end{verbatim} # is present in your \verb+OMakeroot+ file. # # \subsection{Configuration variables} # # The following variables can be modified in your project. # \var{LATEX} The \LaTeX\ command (default \verb+latex+). # \varlabel{TETEX2_ENABLED}{TETEX2\_ENABLED} Flag indicating whether to use advanced \LaTeX\ options # present in TeTeX v.2 (default value is determined the first time omake reads \verb+LaTeX.src+ # and depends on the version of \LaTeX\ you have installed). # \var{LATEXFLAGS} The \LaTeX\ flags (defaults depend on the \verb+TETEX2_ENABLED+ variable) # \var{BIBTEX} The BibTeX command (default \verb+bibtex+). # \var{MAKEINDEX} The command to build an index (default \verb+makeindex+). # \var{DVIPS} The \verb+.dvi+ to PostScript converter (default \verb+dvips+). # \var{DVIPSFLAGS} Flags to pass to \verb+dvips+ (default \verb+-t letter+). # \var{DVIPDFM} The \verb+.dvi+ to \verb+.pdf+ converter (default \verb+dvipdfm+). # \var{DVIPDFMFLAGS} Flags to pass to \verb+dvipdfm+ (default \verb+-p letter+). # \var{PDFLATEX} The \verb+.latex+ to \verb+.pdf+ converter (default \verb+pdflatex+). # \var{PDFLATEXFLAGS} Flags to pass to pdflatex (default is \verb+$`(LATEXFLAGS)+). # \var{USEPDFLATEX} Flag indicating whether to use pdflatex instead of dvipdfm # to generate the \verb+.pdf+ document (default \verb+false+). # \end{doc} # declare public.LATEXFLAGS public.BIBTEX = bibtex public.MAKEINDEX = makeindex public.DVIPS = dvips public.DVIPSFLAGS = -t letter $`(if $(VERBOSE), $(EMPTY), -q) public.DVIPDFM = dvipdfm public.DVIPDFMFLAGS = -p letter public.PDFLATEX = pdflatex public.PDFLATEXFLAGS = $`(LATEXFLAGS) public.USEPDFLATEX = false public.LATEX = latex # # Configure LaTeX by checking whether some LaTeX options exist. # public. = declare FORCE_WIN32_LATEX if $(not $(defined FORCE_WIN32_LATEX)) FORCE_WIN32_LATEX = false export .STATIC: open configure/Configure # # XXX: JYH: when Cygwin latex is called from Win32, # it often segfaults, and pops up an annoying # ignore/abort window. Try to detect this case # and disable LaTeX. # # XXX: We should move the uname test into configure/uname. # OUTPUT_COMMENT_SUPPORTED = false TETEX2_ENABLED = false FILE_LINE_ERROR = LATEX_USABLE = $(CheckProg latex) if $(and $(LATEX_USABLE), $(not $(FORCE_WIN32_LATEX)), $(equal $(OSTYPE), Win32), $(CheckProg uname)) match($(shell uname)) case CYGWIN ConfMsgWarn($""" You seem to be trying to use Cygwin LaTeX on a Win32 machine. This usually doesn't work, but if you really want to use it, add the following definition to your OMakeroot. FORCE_WIN32_LATEX = true (latex disabled)""") LATEX_USABLE = false export export if $(and $(LATEX_USABLE), $(shell-success-null latex -help)) ConfMsgChecking(LaTeX capabilities) # # Various versions of LaTeX use different options # Look through the -help info for tetex2 options # RECORDER_ENABLED = false ERROR_ENABLED = false BROKEN_MIKTEX = false TETEX_CONFIG_TMP = $(tmpfile tetex) latex -help > $(TETEX_CONFIG_TMP) awk($(TETEX_CONFIG_TMP)) case ^-recorder RECORDER_ENABLED = true export case $'.*-recorder.*Record file names\.' # MikTeX 2.4 had a bug, where -recorder would swap inputs with outputs - # http://bugzilla.metaprl.org/show_bug.cgi?id=632 BROKEN_MIKTEX = true export case $'^ *-output-comment=' OUTPUT_COMMENT_SUPPORTED = true export case $'^ *-recorder' RECORDER_ENABLED = true export case ^-file-line-error-style FILE_LINE_ERROR = -file-line-error-style ERROR_ENABLED = true export case $'^\[-no\]-file-line-error' FILE_LINE_ERROR = -file-line-error ERROR_ENABLED = true export case $'^ *-c-style-errors' FILE_LINE_ERROR = -c-style-errors ERROR_ENABLED = true export # # TeTeX2 if both the -recorder and -file-line-error options exist # RECORDER_ENABLED = $(and $(RECORDER_ENABLED), $(not $(BROKEN_MIKTEX))) TETEX2_ENABLED = $(and $(RECORDER_ENABLED), $(ERROR_ENABLED)) ConfMsgResult(tetex2 mode $(if $(TETEX2_ENABLED), enabled, disabled)) rm $(TETEX_CONFIG_TMP) export FILE_LINE_ERROR TETEX2_ENABLED OUTPUT_COMMENT_SUPPORTED # # Compute the default flags # LATEXFLAGS_BASE = $(if $(OUTPUT_COMMENT_SUPPORTED), $'-output-comment=LaTeX Output (built with OMake)') export TETEX2_ENABLED FILE_LINE_ERROR LATEX_USABLE OUTPUT_COMMENT_SUPPORTED LATEXFLAGS_BASE LATEXFLAGS() = if $(TETEX2_ENABLED) value $(FILE_LINE_ERROR) $(LATEXFLAGS_BASE) else value $'-interaction=errorstopmode' $(LATEXFLAGS_BASE) # # Dynamically defined list of files that the TeX source depends on. # public.TEXDEPS = # # Directories in the search path. # Split them at colons to get a directory list. # public.TEXINPUTS = $(split $(PATHSEP), $(getenv TEXINPUTS, .)) # # TeX can log its inputs and outputs into an .fls file. We use the internal awk # to turn an .fls file into in appropriate dependency file format. # Shell. += protected.builtin-tex-deps(argv) = private. = dep = $(nth 0, $(argv)) f = $(nth 1, $(argv)) public. = DEPS[] = WRITES[] = $(file $f.bbl $f.ind) DEPDIR = $(dir .) awk($f.fls) case $'^PWD \(.*\)$' DEPDIR = $(dir $1) export case $'^INPUT \(.*\)$' DEPS += $(cd $(DEPDIR), $(file $1)) export case $'^OUTPUT \(.*\)$' WRITES += $(cd $(DEPDIR), $(file $1)) export if $(file-exists $f.aux) FS=$'[{}]' awk($f.aux) case $'\\bibdata\{.*\}' BIBS = $(split \,, $2) BIBS[] = $(BIBS) $(addsuffix .bib, $(BIBS)) DEPS += $(find-in-path-optional $(split \:, $(getenv BIBINPUTS)), $(BIBS)) export DEPS case $'\\bibstyle\{.*\}' BSTS = $(split \,, $2) BSTS[] = $(BSTS) $(addsuffix .bst, $(BSTS)) DEPS += $(find-in-path-optional $(split \:, $(getenv BSTINPUTS)), $(BSTS)) export DEPS export DEPS DEPS = $(set-diff $(DEPS), $(WRITES)) println($"$(string-escaped $(dep)): $(string-escaped $(DEPS))") eprintln($"$(string-escaped $(dep)): $(string-escaped $(DEPS))") protected.stdout-to-stderr(argv) = stdout = $(stderr) $(argv) protected.run-latex(argv) = if $(TETEX2_ENABLED) if $(not $(shell-success $(argv))) private.f = $(replacesuffixes .tex, $(string $(EMPTY)), $(last $(argv))) eprintln(*** Errors detected while running LaTeX on $(private.f).tex:) stdout-to-stderr grep ':[1-9][0-9]*: ' $(private.f).log exit 1 else $(argv) # # Rules for building TeX documents. # # name: the name of the document # texfiles: the TeX source files, without suffix # # Dynamic variables: # TEXINPUTS: extra directories to include in the search path # TEXDEPS: files that are implicitly included, including suffixes # # \begin{doc} # \subsection{Building \LaTeX\ documents} # \fun{LaTeXDocument} # # The \verb+LaTeXDocument+ produces a \LaTeX\ document. # # \verb+LaTeXDocument(, )+ # # The document \verb++ and \verb++ are listed without suffixes. This function # returns the filenames for the generated \verb+.ps+ (unless \hypervar{USEPDFLATEX} is set) and \verb+.pdf+ files. # # Additional variables used: # \var{TEXINPUTS} # The \LaTeX\ search path (an array of directories, default is # taken from the \verb+TEXINPUTS+ environment variable). # \var{TEXDEPS} Additional files this document depends on. # \var{TEXVARS} An array of names of the environment variables # that are to be updated based on the value of \OMake's \verb+TEXINPUTS+ variable. # Defaults to \verb+TEXINPUTS+ \verb+BIBINPUTS+ \verb+BSTINPUTS+. # \end{doc} # # Make sure generated files are built before scanning # # \begin{doc} # \twofuns{TeXGeneratedFiles}{LocalTeXGeneratedFiles} # \begin{verbatim} # TeXGeneratedFiles(files) # LocalTeXGeneratedFiles(files) # \end{verbatim} # # The \verb+TeXGeneratedFiles+ and \verb+LocalTeXGeneratedFiles+ functions specify files # that need to be generated before any \LaTeX files are scanned for dependencies. For example, # if \verb+config.tex+ and \verb+inputs.tex+ are both generated files, specify: # \begin{verbatim} # TeXGeneratedFiles(config.tex inputs.tex) # \end{verbatim} # # The \verb+TeXGeneratedFiles+ function is \emph{global} --- its arguments will be generated # before any TeX files anywhere in the project are scanned for dependencies. The # \verb+LocalTeXGeneratedFiles+ function follows the normal scoping rules of \OMake. # # \end{doc} public.TEXVARS[] = TEXINPUTS BIBINPUTS BSTINPUTS .PHONY: TeXGeneratedFilesTarget public.TeXGeneratedFiles(files) = TeXGeneratedFilesTarget: $(files) public.LocalTeXGeneratedFiles(files) = .SCANNER: scan-tex-%: $(files) export Shell. += protected.drop-dvips-junk(argv) = private.print = true awk() case $'dvips: Could not find figure file pdf:[a-z]*; continuing': print = false export case $'dvips: Unknown keyword [(].*[)] in \\special will be ignored': print = false export case $"dvips: more errors in special, being ignored": print = false export case $"dvips: [(]perhaps dvips doesn't support your macro package[?][)]": print = false export default if $(print) println($0) print = true export return true public.LaTeXDocument(name, texfiles) = name = $(file $(name)) # # TeX files all have the .tex suffix # protected.TEXFILES[] = $(name).tex $(addsuffix .tex, $(texfiles)) # # Setting the proper TEXINPUTS environment # private.INPUTS = $(concat $(PATHSEP), $(TEXINPUTS))$(PATHSEP) foreach(var => ..., $(TEXVARS)) setenv($(var), $(private.INPUTS)) export private.prog = $(if $(USEPDFLATEX), $(PDFLATEX), $(LATEX)) private.flags = $(if $(USEPDFLATEX), $(PDFLATEXFLAGS), $(LATEXFLAGS)) private.ext = $(if $(USEPDFLATEX), .pdf, .dvi) $(name)$(ext): $(TEXDEPS) $(TEXFILES) :effects: $(name).aux $(name).log $(name).ind $(name).out if $(gt $(length $(TEXVARS)), 0) echo "Enviroment variables $(concat $', ', $(TEXVARS)) set to $(getenv $(nth 0, $(TEXVARS)))" run-latex $(prog) $(flags) $(name) if $(and $(file-exists $(name).aux), $(grep q, $'\\citation', $(name).aux), $(grep q, $'\\bibdata', $(name).aux)) $(BIBTEX) $(name) run-latex $(prog) $(flags) $(name) if $(and $(file-exists $(name).idx), $(grep q, $'\\indexentry', $(name).idx)) $(MAKEINDEX) $(name) run-latex $(prog) $(flags) $(name) if $(grep q, $'Rerun to get', $(name).log) run-latex $(prog) $(flags) $(name) if $(grep q, $'Rerun to get', $(name).log) run-latex $(prog) $(flags) $(name) if $(grep q, $'Rerun to get', $(name).log) run-latex $(prog) $(flags) $(name) # # TeTeX2 has the ability to compute dependencies for us # if $(TETEX2_ENABLED) protected.SCANNER = scan-$(if $(USEPDFLATEX), pdflatex, latex)-$(name).tex .SCANNER: $(SCANNER): $(name).tex $(TEXDEPS) $(TEXFILES) /.PHONY/TeXGeneratedFilesTarget\ :value: $(USEPDFLATEX) $(find-in-path-optional $(INPUTS), $&)\ :effects: $(name).aux $(name).log $(name).ind $(name).out $(name).dvi $(name).fls echo | run-latex stdout-to-stderr $(prog) $(flags) -recorder $< builtin-tex-deps $(name)$(ext) $(name) $(name)$(ext): :scanner: $(SCANNER) if $(USEPDFLATEX) return $(file $(name).pdf) else $(name).pdf: $(name).dvi $(DVIPDFM) $(DVIPDFMFLAGS) -o $@ $(name).dvi if $(VERBOSE) $(name).ps: $(name).dvi $(DVIPS) $(DVIPSFLAGS) -o $@ $(name).dvi else $(name).ps: $(name).dvi $(DVIPS) $(DVIPSFLAGS) -o $@ $(name).dvi |& drop-dvips-junk return $(file $(name).ps $(name).pdf) # # Copy the document to a library directory # # \begin{doc} # \fun{LaTeXDocumentCopy} # # The \verb+LaTeXDocumentCopy+ copies the document to an install location. # # \verb+LaTeXDocumentCopy(, , , )+ # # This function copies just the \verb+.pdf+ and \verb+.ps+ files. # \end{doc} # public.LaTeXDocumentCopy(tag, lib, dst, src) = $(lib)/$(dst).pdf: $(src).pdf $(lib) :scanner: $(NOSCANNER) cp $< $@ $(lib)/$(dst).ps: $(src).ps $(lib) :scanner: $(NOSCANNER) cp $< $@ $(tag): $(lib)/$(dst).pdf $(lib)/$(dst).ps return $(file $(lib)/$(dst).pdf $(lib)/$(dst).ps) # # Build the document and copy it # # \begin{doc} # \fun{LaTeXDocumentInstall} # # The \verb+LaTeXDocumentInstall+ builds a document and copies it to an # install location in one step. # # \verb+LaTeXDocumentInstall(, , , , )+ # \end{doc} # public.LaTeXDocumentInstall(tag, lib, dst, src, texfiles) = LaTeXDocument($(src), $(texfiles)) return $(LaTeXDocumentCopy $(tag), $(lib), $(dst), $(src)) omake-0.10.3/lib/build/Common.om0000644000175000017500000001320713177364666014773 0ustar gerdgerd######################################################################## # General configuration. # # Copyright (C) 2003-2005 Jason Hickey and Mojave Group # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this file, to deal in the File without # restriction, including without limitation the rights to use, # copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the File, and to permit persons to whom the File # is furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the File. # # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # FILE OR THE USE OR OTHER DEALINGS IN THE FILE. ######################################################################## # Mention a few of the other standard variables here. # # \begin{doc} # \section{The OMakeroot file} # \index{OMakeroot} # # The standard \File{OMakeroot} file defines the functions are rules # for building standard projects. # # \subsection{Variables} # \var{ROOT} The root directory of the current project. # \var{CWD} The current working directory (the directory is set for each \File{OMakefile} in the project). # \var{EMPTY} The empty string. # \var{STDROOT} The name of the standard installed \File{OMakeroot} file. # \end{doc} # ROOT = $(dir .) LIB = $(dir lib) BIN = $(dir bin) # # A default sort rule # .ORDER: .BUILDORDER # # \begin{doc} # \varlabel{ABORT_ON_COMMAND_ERROR}{ABORT\_ON\_COMMAND\_ERROR} If set to true, the construction of a target should # be aborted whenever one of the commands to build it fail. This defaults to true, # and should normally be left that way. # # \varlabel{SCANNER_MODE}{SCANNER\_MODE} This variable should be defined as one of four values # (defaults to \verb+enabled+). # \begin{description} # \item[enabled] Allow the use of default \verb+.SCANNER+ rules. Whenever a rule does # not specify a \verb+:scanner:+ dependency explicitly, try to find a # \verb+.SCANNER+ with the same target name. # \item[disabled] Never use default \verb+.SCANNER+ rules. # \item[warning] Allow the use of default \verb+.SCANNER+ rules, but print a warning # whenever one is selected. # \item[error] Do not allow the use of default \verb+.SCANNER+ rules. If a rule # does not specify a \verb+:scanner:+ dependency, and there is a default # \verb+.SCANNER+ rule, the build will terminate abnormally. # \end{description} # \end{doc} # # These are defined in Omake_builtin_base # ABORT_ON_COMMAND_ERROR = true # SCANNER_MODE = enabled ######################################################################## # Generic Unix section # # # \begin{doc} # \subsection{System variables} # # \var{INSTALL} The command to install a program (\verb+install+ on \verb+Unix+, \verb+cp+ on \verb+Win32+). # \var{PATHSEP} The normal path separator (\verb+:+ on \verb+Unix+, \verb+;+ on \verb+Win32+). # \var{DIRSEP} The normal directory separator (\verb+/+ on \verb+Unix+, \verb+\+ on \verb+Win32+). # \varlabel{EXT_OBJ}{EXT\_OBJ} File suffix for an object file (default is \verb+.o+ on \verb+Unix+, and \verb+.obj+ on \verb+Win32+). # \varlabel{EXT_LIB}{EXT\_LIB} File suffix for a static library (default is \verb+.a+ on \verb+Unix+, and \verb+.lib+ on \verb+Win32+). # \varlabel{EXT_DLL}{EXT\_DLL} File suffix for a shared library (default is \verb+.so+ on \verb+Unix+, and \verb+.dll+ on \verb+Win32+). # \varlabel{EXT_ASM}{EXT\_ASM} File suffix for an assembly file (default is \verb+.s+ on \verb+Unix+, and \verb+.asm+ on \verb+Win32+). # \var{EXE} File suffix for executables (default is empty for \verb+Unix+, and \verb+.exe+ on \verb+Win32+ and \verb+Cygwin+). # \end{doc} # # # These commands are builtin, and they are the same on all platforms. # The uppercase variables are defined for backwards compatibility only, # their usage is deprecated. # CP = cp MV = mv RM = rm -f MKDIR = mkdir RMDIR = rmdir CHMOD = chmod # We now support both msvc and mingw for Win32. CCOMPTYPE is "msvc" for the # former case and "cc" for the latter. There is some fallback code for old # omake bootstraps, though: if $(not $(defined CCOMPTYPE)) if $(equal $(OSTYPE), Win32) CCOMPTYPE = msvc export else CCOMPTYPE = cc export export #println(ccomptype: $(CCOMPTYPE)) switch $(CCOMPTYPE) case cc EXT_LIB = .a EXT_DLL = .so # but may be overridden below EXT_OBJ = .o EXT_ASM = .s EXE = # but may be overridden below export case msvc EXT_LIB = .lib EXT_DLL = .dll EXT_OBJ = .obj EXT_ASM = .asm EXE = .exe export if $(equal $(OSTYPE), Win32) # # Command names # INSTALL = cp PATHSEP = ; DIRSEP = \\ # # Common suffixes for files # EXT_DLL = .dll EXE = .exe export else # # Command names # INSTALL = install PATHSEP = : DIRSEP = / export if $(equal $(OSTYPE), Cygwin) EXE = .exe export declare LN if $(not $(defined USE_SYSTEM_COMMANDS)) if $(not $(equal $(OSTYPE), Win32)) LN = ln -sf export export else LN = ln-or-cp export # XXX: JYH: this is a total hack. # It should be the case the :scanner: $(EMPTY) turns off scanners. # NOSCANNER = /scan-dummy .SCANNER: $(NOSCANNER) @ omake-0.10.3/lib/configure/0000755000175000017500000000000013177364666014065 5ustar gerdgerdomake-0.10.3/lib/configure/readline.install0000644000175000017500000000377513177364666017254 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) # # Readline configuration # # \begin{doc} # \subsection{ReadLine library configuration} # Add \verb+open configure/readline+ line to your \verb+OMakefile+ to get access to the following # autoconfiguration variables. # \varlabel{READLINE_AVAILABLE}{READLINE\_AVAILABLE} A boolean flag that would be set when both # the \verb+readline/readline.h+ header, the \verb+readline/history.h+ header, and the \verb+readline+ # library very found. # # \varlabel{READLINE_GNU}{READLINE\_GNU} A boolean flag that would be set # when the GNU version of the readline library is found (as opposed to the BSD one). # # \varlabel{READLINE_CFLAGS}{READLINE\_CFLAGS} The \verb+CFLAGS+ to use when compiling readline code. # Will include \verb+-DREADLINE_ENABLED+ and \verb+-DREADLINE_GNU+, respectively # when \verb+READLINE_AVAILABLE+ and \verb+READLINE_GNU+ are true. # # \varlabel{READLINE_CLIBS}{READLINE\_CLIBS} The \verb+LDFLAGS+ to use when linking readline code. # Will normally contain \verb+-lncurses -lreadline+ when readline is found and remain empty otherwise. # \end{doc} # # open configure/Configure open configure/ncurses .STATIC: READLINE_AVAILABLE = false READLINE_CLIBS = READLINE_CFLAGS = READLINE_GNU = false if $(and $(NCURSES_AVAILABLE), $(not $(equal $(OSTYPE), Win32))) ConfMsgChecking(for readline) # Test that readline exists if $(and $(CheckHeader readline/readline.h readline/history.h), $(CheckLib ncurses readline, tgetent tgetstr readline)) READLINE_AVAILABLE = true READLINE_CLIBS = -lncurses -lreadline READLINE_CFLAGS += -DREADLINE_ENABLED # Test for GNU if $(CheckLib ncurses readline, history_list) READLINE_GNU = true READLINE_CFLAGS += -DREADLINE_GNU export export ConfMsgResult($(if $(READLINE_AVAILABLE), $"found, $(if $(not $(READLINE_GNU)), non-)GNU", NOT found)) export omake-0.10.3/lib/configure/snprintf.install0000644000175000017500000000111413177364666017315 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) open configure/Configure # \begin{doc} # \subsection{Snprintf configuration} # Add \verb+open configure/snprintf+ line to your \verb+OMakefile+ to get access to the following # autoconfiguration variables. # \varlabel{SNPRINTF_AVAILABLE}{SNPRINTF\_AVAILABLE} A boolean flag telling whether the snprintf # function is available in the standard C library. # # \end{doc} # .STATIC: SNPRINTF_AVAILABLE = false section SNPRINTF_AVAILABLE = $(VerboseCheckLib $(EMPTY), snprintf) export SNPRINTF_AVAILABLE omake-0.10.3/lib/configure/posix_spawn.install0000644000175000017500000000115013177364666020024 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) open configure/Configure # \begin{doc} # \subsection{Posix_spawn configuration} # Add \verb+open configure/posix_spawn+ line to your \verb+OMakefile+ to get access to the following # autoconfiguration variables. # \varlabel{POSIX_SPAWN_AVAILABLE}{POSIX\_SPAWN\_AVAILABLE} A boolean flag telling whether the posix_spawn # function is available in the standard C library. # # \end{doc} # .STATIC: POSIX_SPAWN_AVAILABLE = false section POSIX_SPAWN_AVAILABLE = $(VerboseCheckLib $(EMPTY), posix_spawn) export POSIX_SPAWN_AVAILABLE omake-0.10.3/lib/configure/moncontrol.install0000644000175000017500000000113613177364666017650 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) open configure/Configure # \begin{doc} # \subsection{Moncontrol configuration} # Add \verb+open configure/moncontrol+ line to your \verb+OMakefile+ to get access to the following # autoconfiguration variables. # \varlabel{MONCONTROL_AVAILABLE}{MONCONTROL\_AVAILABLE} A boolean flag telling whether the moncontrol # function is available in the standard C library. # # \end{doc} # .STATIC: MONCONTROL_AVAILABLE = false section MONCONTROL_AVAILABLE = $(VerboseCheckLib $(EMPTY), moncontrol) export MONCONTROL_AVAILABLE omake-0.10.3/lib/configure/Configure.install0000644000175000017500000002725013177364666017404 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) # # Configuration utilities # # \begin{doc} # \chapter{Autoconfiguration functions and variables} # \label{chapter:autoconf} # \cutname{omake-autoconf.html} # \OMake{} standard library provides a number of functions and variables intended to help one write # build specifications that need to be capable of autoconfiguring itself to adjust to different # build environments. # # \section{General-purpose autoconfiguration functions} # The following general-purpose functions can be used to discover the properties of your build # environment in a fashion similar to the one used by GNU autoconf tool you may be familiar with. # It is recommended that these function be used from an appropriate \verb+static.+ block (see # Section~\ref{section:static.} for more information). # # In order to use the following general-purpose functions, you need to have the line # \begin{verbatim} # open configure/Configure # \end{verbatim} # included in your \verb+OMakefile+ or \verb+OMakeroot+. # \end{doc} open build/Common # # As of 0.9.9, all external variables mut be declared. # Since this module uses the C compiler, we must open build/C. # However, build/C also uses configuration, so we have a # circular dependency. The solution is to "autoload" C, # which means we load it on demand, breaking the cycle. # # In 0.9.8 this is a no-op. # autoload build/C # # A number of helper functions, using the autoconf names, when appropriate. # # \begin{doc} # \twofuns{ConfMsgChecking}{ConfMsgResult} # \begin{verbatim} # ConfMsgChecking() # ... # ConfMsgResult() # \end{verbatim} # The \verb+ConfMsgChecking+ function output message of the form \verb+--- Checking ... + # \emph{without} any trailing newline. After the test advertized by \verb+ConfMsgChecking+ is # performed, the \verb+ConfMsgResult+ function should be used to output the result. # # In certain cases users may want to redefine these function --- for example, to use a different # output formatting and/or to copy the messages to a log file. # # Example: # \begin{verbatim} # static. = # ConfMsgChecking(which foo to use) # foo = ... # ConfMsgResult($(foo)) # \end{verbatim} # \end{doc} # ConfMsgChecking(msg) = print($"--- Checking $(msg)... ") ConfMsgResult(msg) = println($"($(msg))") value $(msg) # \begin{doc} # \twofuns{ConfMsgWarn}{ConfMsgError} # \begin{verbatim} # ConfMsgWarn() # ConfMsgError() # \end{verbatim} # # Print a warning or an error message respectively. \verb+ConfMsgError+ would then abort \OMake. # \end{doc} ConfMsgWarn(msg) = msg[] = $(split $(nl), $(msg)) print($(concat $(EMPTY), $(add-wrapper $'--- *** ', $(nl), $(msg)))) ConfMsgError(msg) = msg[] = $(split $(nl), $(msg)) eprintln($"""*** ERROR: $(concat '$(nl)--- ', $(msg))""") exit(1) # # \begin{doc} # \twofuns{ConfMsgYesNo}{ConfMsgFound} # \begin{verbatim} # flag = $(ConfMsgYesNo # flag = $(ConfMsgFound # \end{verbatim} # # The \verb+ConfMsgFound+ function expects to receive a boolean flag describing whether a test # previously announced using the \hyperfun{ConfMsgChecking} found what it # was looking for. \verb+ConfMsgFound+ will output the appropriate result (``found'' or ``NOT found'') # using the \hyperfun{ConfMsgResult} and return its argument back. # # The \verb+ConfMsgYesNo+ function is similar, outputting a simple (``yes'' or ``NO''). # \end{doc} # ConfMsgYesNo(found) = ConfMsgResult($(if $(found), yes, NO)) return $(found) ConfMsgFound(found) = ConfMsgResult($(if $(found), found, NOT found)) return $(found) # \begin{doc} # \threefuns{TryCompileC}{TryLinkC}{TryRunC} # \begin{verbatim} # success = $(TryCompileC ) # success = $(TryLinkC ) # success = $(TryRunC ) # \end{verbatim} # # Given the \emph{text} of a C program, the \verb+TryCompileC+, \verb+TryLinkC+, and \verb+TryRunC+ # functions would try to compile / compile and link / compile, link, and run, the given program and return a boolean flag # indicating whether the attempt was successful. # # \verb+TryCompileC+ will use the \hypervarn{CC}, \hypervarn{CFLAGS} and \hypervarn{INCLUDES} variables # to run the C compiler. \verb+TryLinkC+ and \verb+TryRunC+ will also use the \hypervar{LDFLAGS} # to run the C compiler and linker. However, the flags like \verb+/WX+, \verb+-Werror+ and \verb+-warn-error+ # will be not be passed to the compiler, even if they occur in \verb+CFLAGS+. # # These functions are silent and should normally be used with an appropriate # \hyperfunn{ConfMsgChecking} $\ldots$ \hyperfunn{ConfMsgResult}. # \end{doc} ConfCleanCFLAGS(cflags) = value $(filter-out /WX -Werror --warn-error, $(cflags)) TryCompilingC(command, command_suffix, ext, prog, extra) = # The command line private.tmp_c = $(file $(tmpfile omake, .c)) private.tmp = $(file $(replacesuffixes .c, $"$(EMPTY)", $(tmp_c))) export command if $(and $(not $(equal $(CCOUT), $(LDOUT))), $(equal $(ext), $(EXE))) command[] += $(CCOUT)$(file $(tmp)$(EXT_OBJ)) $(LDOUT)$(file $(tmp)$(ext)) else command[] += $(CCOUT)$(file $(tmp)$(ext)) command[] += $(file $(tmp_c)) $(command_suffix) # The program program = $"""/* Configuration file; you can remove this. */ /* Command line: $(command) */ $(prog) """ # Compile it fprint($(tmp_c), $(program)) protected.result = $(shell-success-null $(command)) export result if $(result) switch $(extra) case Runs result = $(shell-success-null $(file $(tmp)$(EXE))) case Output result = try value $(shell $(file $(tmp)$(EXE))) default value $(not true) # Remove temporaries rm -f $(tmp_c) $(tmp)$(EXT_OBJ) $(tmp)$(EXE) return $(result) TryCompileC(prog) = return $(TryCompilingC $(CC) $(ConfCleanCFLAGS $(CFLAGS)) $(PREFIXED_INCLUDES) -c, $(EMPTY), $(EXT_OBJ), $(prog), None) TryLinkC(prog) = return $(TryCompilingC $(CC) $(ConfCleanCFLAGS $(CFLAGS)) $(PREFIXED_INCLUDES), $(LDFLAGS), $(EXE), $(prog), None) TryRunC(prog) = return $(TryCompilingC $(CC) $(ConfCleanCFLAGS $(CFLAGS)) $(PREFIXED_INCLUDES), $(LDFLAGS), $(EXE), $(prog), Runs) # \begin{doc} # \fun{RunCProg} # \begin{verbatim} # output = $(RunCProg ) # \end{verbatim} # # \verb+RunCProg+ is similar to the \hyperfun{RunCProg}, except that it # returns the output of the function (will return \verb+false+ if the program fails to compile # or run). # \end{doc} RunCProg(prog) = return $(TryCompilingC $(CC) $(ConfCleanCFLAGS $(CFLAGS)) $(PREFIXED_INCLUDES), $(LDFLAGS), $(EXE), $(prog), Output) # # Check whether a header file exists. # We call the C compiler. # # \begin{doc} # \twofuns{CheckCHeader}{VerboseCheckCHeader} # \begin{verbatim} # success = $(CheckCHeader ) # success = $(VerboseCheckCHeader ) # \end{verbatim} # # Use the \hyperfun{TryCompileC} to check whether your C compiler can locate # and process the specified headers files. # Will incude \verb++ before including the header files. # # Both functions return a boolean value. The \verb+CheckCHeader+ function is silent; the # \verb+VerboseCheckCHeader+ function will use the \hyperfunn{ConfMsgChecking} and # \hyperfunn{ConfMsgResult} functions to describe the test and the outcome. # # Example: # \begin{verbatim} # static. = # NCURSES_H_AVAILABLE = $(VerboseCheckCHeader ncurses.h) # \end{verbatim} # \end{doc} # public.CheckCHeader(files) = return $(TryCompileC $""" #ifdef __cplusplus extern "C" #endif #pragma warning( disable : 4100 ) #include $(add-wrapper $(nl)$'#include <', >, $(files)) int main(int argc, char **argv) { return 0; } """) public.VerboseCheckCHeader(files) = ConfMsgChecking(for $(files)) return $(ConfMsgFound $(CheckCHeader $(files))) # # Check whether the libraries have the given functions # # \begin{doc} # \twofuns{CheckCLib}{VerboseCheckCLib} # \begin{verbatim} # success = $(CheckCLib , ) # success = $(VerboseCheckCLib , ) # \end{verbatim} # # Use the \hyperfun{TryLinkC} to check whether your C compiler and linker can # find the named functions when linking with the named libraries. Will pass the \verb++ to # the compiler using the \verb+-l+ flag. # # Both functions return a boolean value. The \verb+CheckCLib+ function is silent; the # \verb+VerboseCheckCHeader+ function will use the \hyperfunn{ConfMsgChecking} and # \hyperfunn{ConfMsgResult} functions to describe the test and the outcome. # # Example: # \begin{verbatim} # static. = # NCURSES_LIB_AVAILABLE = $(VerboseCheckCLib ncurses, initscr setupterm tigetstr) # \end{verbatim} # \end{doc} # public.CheckCLib(libs, funs) = LDFLAGS += $(addprefix -l, $(libs)) return $(TryLinkC $""" #ifdef __cplusplus extern "C" #endif #pragma warning( disable : 4100 ) /* Override any gcc2 internal prototype to avoid an error. */ $(add-wrapper $(nl)extern char , $'();', $(funs)) int main(int argc, char **argv) { /* Usage */ $(add-wrapper $(nl) , $'();', $(funs)) return 0; } """) public.VerboseCheckCLib(libs, funs) = msg1 = $(if $(funs), $"""function$(if $(gt $(length $(funs)), 1), s) $(concat $", ", $(funs))""") msg2 = $(if $(libs), $"""librar$(if $(gt $(length $(libs)), 1), ies, y) $(concat $", ", $(libs))""") ConfMsgChecking($"""for $(msg1)$(if $(not $(or $(not $(funs)), $(not $(libs)))), $' in ')$(msg2)""") return $(ConfMsgFound $(CheckCLib $(libs), $(funs))) # # Backwards compatibility # # XXX: Once we decide how we are going to provide the multi-language support, # we should either update these or have them produce an "obsolete" warning. # public.CheckLib = $(CheckCLib) public.VerboseCheckLib = $(VerboseCheckCLib) public.CheckHeader = $(CheckCHeader) public.VerboseCheckHeader = $(VerboseCheckCHeader) # # Check whether a program exists in the PATH # # \begin{doc} # \fun{CheckProg} # \verb+success = $(CheckProg )+ # # Checks whether the program \verb++ exists in your path. Will use the # \hyperfunn{ConfMsgChecking} and # \hyperfunn{ConfMsgResult} functions to describe the test and the outcome. # # \end{doc} # public.CheckProg(prog) = ConfMsgChecking(for $(prog)) WHERE = $(where $(quote-argv $(prog))) if $(WHERE) ConfMsgResult(found $(nth 0, $(WHERE))) return true else ConfMsgResult(FAILED - no $(prog) found) return false # # \begin{doc} # \section{Translating \code{autoconf} scripts} # Some of the functions described above are very similar to the ones present in \verb+autoconf+. # Below is a brief translation table for such functions. # \begin{description} # \itemidx{AC\_MSG\_CHECKING} is very similar to \hyperfun{ConfMsgChecking}. # \itemidx{AC\_MSG\_RESULT} is very similar to \hyperfun{ConfMsgResult}. # \itemidx{AC\_MSG\_WARN} is very similar to \hyperfun{ConfMsgWarn}. # \itemidx{AC\_MSG\_ERROR} is very similar to \hyperfun{ConfMsgError}. # \itemidx{AC\_TRY\_COMPILE} is somewhat similar to \hyperfun{TryCompileC}, # except the \hyperfun{TryCompileC} returns a boolean value and only works for \verb+C+. Similarly, # \itemidx{AC\_TRY\_LINK} is approximated by \hyperfun{TryLinkC}, and # \itemidx{AC\_TRY\_RUN} is approximated by \hyperfun{TryRunC}. # \end{description} # # \section{Predefined configuration tests} # A number of configuration tests are already included in the standard library. # In order to use them in your project, simply \verb+open+ (see Section~\ref{section:include}) the # corresponding build file in your \verb+OMakefile+ and the tests will run the first time \OMake{} # is executed. Note that it is not a problem to \verb+open+ these files from more than one place in # your project --- if you do that, the test will still run only once. # \end{doc} # omake-0.10.3/lib/configure/X.install0000644000175000017500000000231013177364666015660 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) # # Some basic test for X. # static. = X_LDFLAGS = X_INCLUDES = if $(CheckProg xmkmf) FOUND_INCLUDES = false FOUND_LIB = false ConfMsgChecking(for X library and header location") mkdir .conftest.dir CWD = $(dir .) cd .conftest.dir fprintln(Imakefile, $(EMPTY)) if $(and $(shell-success-null xmkmf), $(test -r Makefile)) awk(Makefile) case $'^[[:space:]]*INCROOT[[:space:]]*=[[:space:]]*\(.*\)$' FOUND_INCLUDES = true if $(not $(equal $1, /usr/include)) X_INCLUDES = $(dir $"$1") export export case $'^[[:space:]]*(USR)?LIBDIR[[:space:]]*=[[:space:]]*\(.*\)$' if $(glob iF, $1/libX11.*) FOUND_LIB = true if $(not $(mem $1, /usr/lib /lib)) X_LDFLAGS = $"-L$1" export export export ConfMsgFound($(and $(FOUND_INCLUDES), $(FOUND_LIB))) cd $(CWD) rm -rf .conftest.dir export X_LDFLAGS X_INCLUDES omake-0.10.3/lib/configure/fam.install0000644000175000017500000000424413177364666016224 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) open configure/Configure # # Figure out if FAM is installed # .STATIC: FAM_AVAILABLE = false FAM_CFLAGS = FAM_CLIBS = if $(equal $(OSTYPE), Win32) FAM_AVAILABLE = true if $(equal $(CCOMPTYPE), msvc) FAM_CFLAGS = /DFAM_ENABLED /DFAM_PSEUDO export else FAM_CFLAGS = -DFAM_ENABLED -DFAM_PSEUDO export export else # Unix # check whether inotify can be used in Linux if $(equal $(SYSNAME), Linux) ConfMsgChecking(for inotify) if $(CheckHeader sys/inotify.h) ConfMsgResult(found) FAM_AVAILABLE = true FAM_CLIBS = FAM_CFLAGS = -DFAM_ENABLED -DFAM_PSEUDO -DFAM_INOTIFY FAM_CFLAGS += -DHAVE_INOTIFY_H export export # for another Unix systems if $(not $(FAM_AVAILABLE)) ConfMsgChecking(for FAM) # See if the FamOpen function exists FAM_AVAILABLE = $(and $(CheckHeader fam.h), $(CheckLib fam, FAMOpen)) # If native FAM doesn't exist, try using kqueue if $(FAM_AVAILABLE) FAM_CLIBS = -lfam FAM_CFLAGS = -DFAM_ENABLED ConfMsgResult(found) ConfMsgChecking($"whether FAM supports Gamin's extensions") if $(ConfMsgYesNo $(CheckLib fam, FAMNoExists)) FAM_CFLAGS += -DHAVE_FAMNOEXISTS export export elseif $(CheckHeader sys/event.h) ConfMsgResult(using kqueue) FAM_AVAILABLE = true FAM_CFLAGS = -DFAM_ENABLED -DFAM_PSEUDO -DFAM_KQUEUE FAM_CLIBS = if $(VerboseCheckHeader string.h) FAM_CFLAGS += -DHAVE_STRING_H export if $(VerboseCheckHeader strings.h) FAM_CFLAGS += -DHAVE_STRINGS_H export export else ConfMsgResult(NOT found) export export omake-0.10.3/lib/configure/fs_case_sensitive.install0000644000175000017500000000264313177364666021156 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) open configure/Configure .STATIC: DETECT_FS_CASE_SENSITIVE = false DETECT_FS_CASE_SENSITIVE_CFLAGS = if $(equal $(OSTYPE), Win32) DETECT_FS_CASE_SENSITIVE = false export else ConfMsgChecking(for optimal filesystem case-sensitivity test) if $(TryLinkC $""" /* For statfs */ #include #include /* For getattrlist */ #include #include typedef struct vol_caps_buf { unsigned long size; vol_capabilities_attr_t caps; } vol_caps_buf_t; /* This is nonsense, but it includes every identifier we care about */ int main(int argc, char *argv[]) { struct statfs stat; statfs(".", &stat); struct attrlist alist; alist.bitmapcount = ATTR_BIT_MAP_COUNT; alist.volattr = ATTR_VOL_CAPABILITIES; vol_caps_buf_t buffer; getattrlist(stat.f_mntonname, &alist, &buffer, sizeof(buffer), 0); /* Check for the capabilities we need */ int foo = ATTR_VOL_CAPABILITIES + VOL_CAPABILITIES_FORMAT + VOL_CAP_FMT_CASE_SENSITIVE; return 0; } """) ConfMsgResult($"Mac OS X implementation, using getattrlist") DETECT_FS_CASE_SENSITIVE = true DETECT_FS_CASE_SENSITIVE_CFLAGS = -DDETECT_FS_CASE_SENSITIVE_GETATTRLIST export else ConfMsgResult(Generic) export omake-0.10.3/lib/configure/ncurses.install0000644000175000017500000000341513177364666017142 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) open configure/Configure # # ncurses configuration # # \begin{doc} # \subsection{NCurses library configuration} # Add \verb+open configure/ncurses+ line to your \verb+OMakefile+ to get access to the following # autoconfiguration variables. # \varlabel{NCURSES_AVAILABLE}{NCURSES\_AVAILABLE} A boolean flag that would be set when both # the \verb+curses.h+ header, the \verb+term.h+ header, and the \verb+ncurses+ library very found. # # \varlabel{NCURSES_TERMH_IN_NCURSES}{NCURSES\_TERMH\_IN\_NCURSES} A boolean flag that would be set # when \verb+term.h+ has to be included as \verb++ instead of \verb++. # # \varlabel{NCURSES_CFLAGS}{NCURSES\_CFLAGS} The \verb+CFLAGS+ to use when compiling ncurses code. # Will include \verb+-DNCURSES+ and \verb+-DTERMH_IN_NCURSES+, respectively # when \verb+NCURSES_AVAILABLE+ and \verb+NCURSES_TERMH_IN_NCURSES+ are true. # # \varlabel{NCURSES_CLIBS}{NCURSES\_CLIBS} The \verb+LDFLAGS+ to use when linking ncurses code. # Will normally contain \verb+-lncurses+ when ncurses is found and remain empty otherwise. # \end{doc} # # \end{doc} # .STATIC: NCURSES_AVAILABLE = false NCURSES_TERMH_IN_NCURSES = false if $(not $(equal $(OSTYPE), Win32)) ConfMsgChecking(for ncurses) NCURSES_TERMH_IN_NCURSES = $(CheckHeader ncurses/term.h) NCURSES_AVAILABLE = $(ConfMsgFound $(and $(CheckHeader ncurses.h), $(or $(NCURSES_TERMH_IN_NCURSES), $(CheckHeader term.h)), $(CheckLib ncurses, initscr setupterm tigetstr))) export NCURSES_CFLAGS[] = $(if $(NCURSES_AVAILABLE), -DNCURSES, $(EMPTY_ARRAY)) $(if $(NCURSES_TERMH_IN_NCURSES), -DTERMH_IN_NCURSES, $(EMPTY_ARRAY)) NCURSES_CLIBS = $(if $(NCURSES_AVAILABLE), -lncurses) omake-0.10.3/lib/configure/fs_case_sensitive.om0000644000175000017500000000254413177364666020123 0ustar gerdgerdopen configure/Configure .STATIC: DETECT_FS_CASE_SENSITIVE = false DETECT_FS_CASE_SENSITIVE_CFLAGS = if $(equal $(OSTYPE), Win32) DETECT_FS_CASE_SENSITIVE = false export else ConfMsgChecking(for optimal filesystem case-sensitivity test) if $(TryLinkC $""" /* For statfs */ #include #include /* For getattrlist */ #include #include typedef struct vol_caps_buf { unsigned long size; vol_capabilities_attr_t caps; } vol_caps_buf_t; /* This is nonsense, but it includes every identifier we care about */ int main(int argc, char *argv[]) { struct statfs stat; statfs(".", &stat); struct attrlist alist; alist.bitmapcount = ATTR_BIT_MAP_COUNT; alist.volattr = ATTR_VOL_CAPABILITIES; vol_caps_buf_t buffer; getattrlist(stat.f_mntonname, &alist, &buffer, sizeof(buffer), 0); /* Check for the capabilities we need */ int foo = ATTR_VOL_CAPABILITIES + VOL_CAPABILITIES_FORMAT + VOL_CAP_FMT_CASE_SENSITIVE; return 0; } """) ConfMsgResult($"Mac OS X implementation, using getattrlist") DETECT_FS_CASE_SENSITIVE = true DETECT_FS_CASE_SENSITIVE_CFLAGS = -DDETECT_FS_CASE_SENSITIVE_GETATTRLIST export else ConfMsgResult(Generic) export omake-0.10.3/lib/configure/X.om0000644000175000017500000000221113177364666014625 0ustar gerdgerd# # Some basic test for X. # static. = X_LDFLAGS = X_INCLUDES = if $(CheckProg xmkmf) FOUND_INCLUDES = false FOUND_LIB = false ConfMsgChecking(for X library and header location") mkdir .conftest.dir CWD = $(dir .) cd .conftest.dir fprintln(Imakefile, $(EMPTY)) if $(and $(shell-success-null xmkmf), $(test -r Makefile)) awk(Makefile) case $'^[[:space:]]*INCROOT[[:space:]]*=[[:space:]]*\(.*\)$' FOUND_INCLUDES = true if $(not $(equal $1, /usr/include)) X_INCLUDES = $(dir $"$1") export export case $'^[[:space:]]*(USR)?LIBDIR[[:space:]]*=[[:space:]]*\(.*\)$' if $(glob iF, $1/libX11.*) FOUND_LIB = true if $(not $(mem $1, /usr/lib /lib)) X_LDFLAGS = $"-L$1" export export export ConfMsgFound($(and $(FOUND_INCLUDES), $(FOUND_LIB))) cd $(CWD) rm -rf .conftest.dir export X_LDFLAGS X_INCLUDES omake-0.10.3/lib/configure/fam.om0000644000175000017500000000414513177364666015171 0ustar gerdgerdopen configure/Configure # # Figure out if FAM is installed # .STATIC: FAM_AVAILABLE = false FAM_CFLAGS = FAM_CLIBS = if $(equal $(OSTYPE), Win32) FAM_AVAILABLE = true if $(equal $(CCOMPTYPE), msvc) FAM_CFLAGS = /DFAM_ENABLED /DFAM_PSEUDO export else FAM_CFLAGS = -DFAM_ENABLED -DFAM_PSEUDO export export else # Unix # check whether inotify can be used in Linux if $(equal $(SYSNAME), Linux) ConfMsgChecking(for inotify) if $(CheckHeader sys/inotify.h) ConfMsgResult(found) FAM_AVAILABLE = true FAM_CLIBS = FAM_CFLAGS = -DFAM_ENABLED -DFAM_PSEUDO -DFAM_INOTIFY FAM_CFLAGS += -DHAVE_INOTIFY_H export export # for another Unix systems if $(not $(FAM_AVAILABLE)) ConfMsgChecking(for FAM) # See if the FamOpen function exists FAM_AVAILABLE = $(and $(CheckHeader fam.h), $(CheckLib fam, FAMOpen)) # If native FAM doesn't exist, try using kqueue if $(FAM_AVAILABLE) FAM_CLIBS = -lfam FAM_CFLAGS = -DFAM_ENABLED ConfMsgResult(found) ConfMsgChecking($"whether FAM supports Gamin's extensions") if $(ConfMsgYesNo $(CheckLib fam, FAMNoExists)) FAM_CFLAGS += -DHAVE_FAMNOEXISTS export export elseif $(CheckHeader sys/event.h) ConfMsgResult(using kqueue) FAM_AVAILABLE = true FAM_CFLAGS = -DFAM_ENABLED -DFAM_PSEUDO -DFAM_KQUEUE FAM_CLIBS = if $(VerboseCheckHeader string.h) FAM_CFLAGS += -DHAVE_STRING_H export if $(VerboseCheckHeader strings.h) FAM_CFLAGS += -DHAVE_STRINGS_H export export else ConfMsgResult(NOT found) export export omake-0.10.3/lib/configure/ncurses.om0000644000175000017500000000331613177364666016107 0ustar gerdgerdopen configure/Configure # # ncurses configuration # # \begin{doc} # \subsection{NCurses library configuration} # Add \verb+open configure/ncurses+ line to your \verb+OMakefile+ to get access to the following # autoconfiguration variables. # \varlabel{NCURSES_AVAILABLE}{NCURSES\_AVAILABLE} A boolean flag that would be set when both # the \verb+curses.h+ header, the \verb+term.h+ header, and the \verb+ncurses+ library very found. # # \varlabel{NCURSES_TERMH_IN_NCURSES}{NCURSES\_TERMH\_IN\_NCURSES} A boolean flag that would be set # when \verb+term.h+ has to be included as \verb++ instead of \verb++. # # \varlabel{NCURSES_CFLAGS}{NCURSES\_CFLAGS} The \verb+CFLAGS+ to use when compiling ncurses code. # Will include \verb+-DNCURSES+ and \verb+-DTERMH_IN_NCURSES+, respectively # when \verb+NCURSES_AVAILABLE+ and \verb+NCURSES_TERMH_IN_NCURSES+ are true. # # \varlabel{NCURSES_CLIBS}{NCURSES\_CLIBS} The \verb+LDFLAGS+ to use when linking ncurses code. # Will normally contain \verb+-lncurses+ when ncurses is found and remain empty otherwise. # \end{doc} # # \end{doc} # .STATIC: NCURSES_AVAILABLE = false NCURSES_TERMH_IN_NCURSES = false if $(not $(equal $(OSTYPE), Win32)) ConfMsgChecking(for ncurses) NCURSES_TERMH_IN_NCURSES = $(CheckHeader ncurses/term.h) NCURSES_AVAILABLE = $(ConfMsgFound $(and $(CheckHeader ncurses.h), $(or $(NCURSES_TERMH_IN_NCURSES), $(CheckHeader term.h)), $(CheckLib ncurses, initscr setupterm tigetstr))) export NCURSES_CFLAGS[] = $(if $(NCURSES_AVAILABLE), -DNCURSES, $(EMPTY_ARRAY)) $(if $(NCURSES_TERMH_IN_NCURSES), -DTERMH_IN_NCURSES, $(EMPTY_ARRAY)) NCURSES_CLIBS = $(if $(NCURSES_AVAILABLE), -lncurses) omake-0.10.3/lib/configure/readline.om0000644000175000017500000000367613177364666016221 0ustar gerdgerd# # Readline configuration # # \begin{doc} # \subsection{ReadLine library configuration} # Add \verb+open configure/readline+ line to your \verb+OMakefile+ to get access to the following # autoconfiguration variables. # \varlabel{READLINE_AVAILABLE}{READLINE\_AVAILABLE} A boolean flag that would be set when both # the \verb+readline/readline.h+ header, the \verb+readline/history.h+ header, and the \verb+readline+ # library very found. # # \varlabel{READLINE_GNU}{READLINE\_GNU} A boolean flag that would be set # when the GNU version of the readline library is found (as opposed to the BSD one). # # \varlabel{READLINE_CFLAGS}{READLINE\_CFLAGS} The \verb+CFLAGS+ to use when compiling readline code. # Will include \verb+-DREADLINE_ENABLED+ and \verb+-DREADLINE_GNU+, respectively # when \verb+READLINE_AVAILABLE+ and \verb+READLINE_GNU+ are true. # # \varlabel{READLINE_CLIBS}{READLINE\_CLIBS} The \verb+LDFLAGS+ to use when linking readline code. # Will normally contain \verb+-lncurses -lreadline+ when readline is found and remain empty otherwise. # \end{doc} # # open configure/Configure open configure/ncurses .STATIC: READLINE_AVAILABLE = false READLINE_CLIBS = READLINE_CFLAGS = READLINE_GNU = false if $(and $(NCURSES_AVAILABLE), $(not $(equal $(OSTYPE), Win32))) ConfMsgChecking(for readline) # Test that readline exists if $(and $(CheckHeader readline/readline.h readline/history.h), $(CheckLib ncurses readline, tgetent tgetstr readline)) READLINE_AVAILABLE = true READLINE_CLIBS = -lncurses -lreadline READLINE_CFLAGS += -DREADLINE_ENABLED # Test for GNU if $(CheckLib ncurses readline, history_list) READLINE_GNU = true READLINE_CFLAGS += -DREADLINE_GNU export export ConfMsgResult($(if $(READLINE_AVAILABLE), $"found, $(if $(not $(READLINE_GNU)), non-)GNU", NOT found)) export omake-0.10.3/lib/configure/snprintf.om0000644000175000017500000000101513177364666016262 0ustar gerdgerdopen configure/Configure # \begin{doc} # \subsection{Snprintf configuration} # Add \verb+open configure/snprintf+ line to your \verb+OMakefile+ to get access to the following # autoconfiguration variables. # \varlabel{SNPRINTF_AVAILABLE}{SNPRINTF\_AVAILABLE} A boolean flag telling whether the snprintf # function is available in the standard C library. # # \end{doc} # .STATIC: SNPRINTF_AVAILABLE = false section SNPRINTF_AVAILABLE = $(VerboseCheckLib $(EMPTY), snprintf) export SNPRINTF_AVAILABLE omake-0.10.3/lib/configure/Configure.om0000644000175000017500000002715113177364666016351 0ustar gerdgerd# # Configuration utilities # # \begin{doc} # \chapter{Autoconfiguration functions and variables} # \label{chapter:autoconf} # \cutname{omake-autoconf.html} # \OMake{} standard library provides a number of functions and variables intended to help one write # build specifications that need to be capable of autoconfiguring itself to adjust to different # build environments. # # \section{General-purpose autoconfiguration functions} # The following general-purpose functions can be used to discover the properties of your build # environment in a fashion similar to the one used by GNU autoconf tool you may be familiar with. # It is recommended that these function be used from an appropriate \verb+static.+ block (see # Section~\ref{section:static.} for more information). # # In order to use the following general-purpose functions, you need to have the line # \begin{verbatim} # open configure/Configure # \end{verbatim} # included in your \verb+OMakefile+ or \verb+OMakeroot+. # \end{doc} open build/Common # # As of 0.9.9, all external variables mut be declared. # Since this module uses the C compiler, we must open build/C. # However, build/C also uses configuration, so we have a # circular dependency. The solution is to "autoload" C, # which means we load it on demand, breaking the cycle. # # In 0.9.8 this is a no-op. # autoload build/C # # A number of helper functions, using the autoconf names, when appropriate. # # \begin{doc} # \twofuns{ConfMsgChecking}{ConfMsgResult} # \begin{verbatim} # ConfMsgChecking() # ... # ConfMsgResult() # \end{verbatim} # The \verb+ConfMsgChecking+ function output message of the form \verb+--- Checking ... + # \emph{without} any trailing newline. After the test advertized by \verb+ConfMsgChecking+ is # performed, the \verb+ConfMsgResult+ function should be used to output the result. # # In certain cases users may want to redefine these function --- for example, to use a different # output formatting and/or to copy the messages to a log file. # # Example: # \begin{verbatim} # static. = # ConfMsgChecking(which foo to use) # foo = ... # ConfMsgResult($(foo)) # \end{verbatim} # \end{doc} # ConfMsgChecking(msg) = print($"--- Checking $(msg)... ") ConfMsgResult(msg) = println($"($(msg))") value $(msg) # \begin{doc} # \twofuns{ConfMsgWarn}{ConfMsgError} # \begin{verbatim} # ConfMsgWarn() # ConfMsgError() # \end{verbatim} # # Print a warning or an error message respectively. \verb+ConfMsgError+ would then abort \OMake. # \end{doc} ConfMsgWarn(msg) = msg[] = $(split $(nl), $(msg)) print($(concat $(EMPTY), $(add-wrapper $'--- *** ', $(nl), $(msg)))) ConfMsgError(msg) = msg[] = $(split $(nl), $(msg)) eprintln($"""*** ERROR: $(concat '$(nl)--- ', $(msg))""") exit(1) # # \begin{doc} # \twofuns{ConfMsgYesNo}{ConfMsgFound} # \begin{verbatim} # flag = $(ConfMsgYesNo # flag = $(ConfMsgFound # \end{verbatim} # # The \verb+ConfMsgFound+ function expects to receive a boolean flag describing whether a test # previously announced using the \hyperfun{ConfMsgChecking} found what it # was looking for. \verb+ConfMsgFound+ will output the appropriate result (``found'' or ``NOT found'') # using the \hyperfun{ConfMsgResult} and return its argument back. # # The \verb+ConfMsgYesNo+ function is similar, outputting a simple (``yes'' or ``NO''). # \end{doc} # ConfMsgYesNo(found) = ConfMsgResult($(if $(found), yes, NO)) return $(found) ConfMsgFound(found) = ConfMsgResult($(if $(found), found, NOT found)) return $(found) # \begin{doc} # \threefuns{TryCompileC}{TryLinkC}{TryRunC} # \begin{verbatim} # success = $(TryCompileC ) # success = $(TryLinkC ) # success = $(TryRunC ) # \end{verbatim} # # Given the \emph{text} of a C program, the \verb+TryCompileC+, \verb+TryLinkC+, and \verb+TryRunC+ # functions would try to compile / compile and link / compile, link, and run, the given program and return a boolean flag # indicating whether the attempt was successful. # # \verb+TryCompileC+ will use the \hypervarn{CC}, \hypervarn{CFLAGS} and \hypervarn{INCLUDES} variables # to run the C compiler. \verb+TryLinkC+ and \verb+TryRunC+ will also use the \hypervar{LDFLAGS} # to run the C compiler and linker. However, the flags like \verb+/WX+, \verb+-Werror+ and \verb+-warn-error+ # will be not be passed to the compiler, even if they occur in \verb+CFLAGS+. # # These functions are silent and should normally be used with an appropriate # \hyperfunn{ConfMsgChecking} $\ldots$ \hyperfunn{ConfMsgResult}. # \end{doc} ConfCleanCFLAGS(cflags) = value $(filter-out /WX -Werror --warn-error, $(cflags)) TryCompilingC(command, command_suffix, ext, prog, extra) = # The command line private.tmp_c = $(file $(tmpfile omake, .c)) private.tmp = $(file $(replacesuffixes .c, $"$(EMPTY)", $(tmp_c))) export command if $(and $(not $(equal $(CCOUT), $(LDOUT))), $(equal $(ext), $(EXE))) command[] += $(CCOUT)$(file $(tmp)$(EXT_OBJ)) $(LDOUT)$(file $(tmp)$(ext)) else command[] += $(CCOUT)$(file $(tmp)$(ext)) command[] += $(file $(tmp_c)) $(command_suffix) # The program program = $"""/* Configuration file; you can remove this. */ /* Command line: $(command) */ $(prog) """ # Compile it fprint($(tmp_c), $(program)) protected.result = $(shell-success-null $(command)) export result if $(result) switch $(extra) case Runs result = $(shell-success-null $(file $(tmp)$(EXE))) case Output result = try value $(shell $(file $(tmp)$(EXE))) default value $(not true) # Remove temporaries rm -f $(tmp_c) $(tmp)$(EXT_OBJ) $(tmp)$(EXE) return $(result) TryCompileC(prog) = return $(TryCompilingC $(CC) $(ConfCleanCFLAGS $(CFLAGS)) $(PREFIXED_INCLUDES) -c, $(EMPTY), $(EXT_OBJ), $(prog), None) TryLinkC(prog) = return $(TryCompilingC $(CC) $(ConfCleanCFLAGS $(CFLAGS)) $(PREFIXED_INCLUDES), $(LDFLAGS), $(EXE), $(prog), None) TryRunC(prog) = return $(TryCompilingC $(CC) $(ConfCleanCFLAGS $(CFLAGS)) $(PREFIXED_INCLUDES), $(LDFLAGS), $(EXE), $(prog), Runs) # \begin{doc} # \fun{RunCProg} # \begin{verbatim} # output = $(RunCProg ) # \end{verbatim} # # \verb+RunCProg+ is similar to the \hyperfun{RunCProg}, except that it # returns the output of the function (will return \verb+false+ if the program fails to compile # or run). # \end{doc} RunCProg(prog) = return $(TryCompilingC $(CC) $(ConfCleanCFLAGS $(CFLAGS)) $(PREFIXED_INCLUDES), $(LDFLAGS), $(EXE), $(prog), Output) # # Check whether a header file exists. # We call the C compiler. # # \begin{doc} # \twofuns{CheckCHeader}{VerboseCheckCHeader} # \begin{verbatim} # success = $(CheckCHeader ) # success = $(VerboseCheckCHeader ) # \end{verbatim} # # Use the \hyperfun{TryCompileC} to check whether your C compiler can locate # and process the specified headers files. # Will incude \verb++ before including the header files. # # Both functions return a boolean value. The \verb+CheckCHeader+ function is silent; the # \verb+VerboseCheckCHeader+ function will use the \hyperfunn{ConfMsgChecking} and # \hyperfunn{ConfMsgResult} functions to describe the test and the outcome. # # Example: # \begin{verbatim} # static. = # NCURSES_H_AVAILABLE = $(VerboseCheckCHeader ncurses.h) # \end{verbatim} # \end{doc} # public.CheckCHeader(files) = return $(TryCompileC $""" #ifdef __cplusplus extern "C" #endif #pragma warning( disable : 4100 ) #include $(add-wrapper $(nl)$'#include <', >, $(files)) int main(int argc, char **argv) { return 0; } """) public.VerboseCheckCHeader(files) = ConfMsgChecking(for $(files)) return $(ConfMsgFound $(CheckCHeader $(files))) # # Check whether the libraries have the given functions # # \begin{doc} # \twofuns{CheckCLib}{VerboseCheckCLib} # \begin{verbatim} # success = $(CheckCLib , ) # success = $(VerboseCheckCLib , ) # \end{verbatim} # # Use the \hyperfun{TryLinkC} to check whether your C compiler and linker can # find the named functions when linking with the named libraries. Will pass the \verb++ to # the compiler using the \verb+-l+ flag. # # Both functions return a boolean value. The \verb+CheckCLib+ function is silent; the # \verb+VerboseCheckCHeader+ function will use the \hyperfunn{ConfMsgChecking} and # \hyperfunn{ConfMsgResult} functions to describe the test and the outcome. # # Example: # \begin{verbatim} # static. = # NCURSES_LIB_AVAILABLE = $(VerboseCheckCLib ncurses, initscr setupterm tigetstr) # \end{verbatim} # \end{doc} # public.CheckCLib(libs, funs) = LDFLAGS += $(addprefix -l, $(libs)) return $(TryLinkC $""" #ifdef __cplusplus extern "C" #endif #pragma warning( disable : 4100 ) /* Override any gcc2 internal prototype to avoid an error. */ $(add-wrapper $(nl)extern char , $'();', $(funs)) int main(int argc, char **argv) { /* Usage */ $(add-wrapper $(nl) , $'();', $(funs)) return 0; } """) public.VerboseCheckCLib(libs, funs) = msg1 = $(if $(funs), $"""function$(if $(gt $(length $(funs)), 1), s) $(concat $", ", $(funs))""") msg2 = $(if $(libs), $"""librar$(if $(gt $(length $(libs)), 1), ies, y) $(concat $", ", $(libs))""") ConfMsgChecking($"""for $(msg1)$(if $(not $(or $(not $(funs)), $(not $(libs)))), $' in ')$(msg2)""") return $(ConfMsgFound $(CheckCLib $(libs), $(funs))) # # Backwards compatibility # # XXX: Once we decide how we are going to provide the multi-language support, # we should either update these or have them produce an "obsolete" warning. # public.CheckLib = $(CheckCLib) public.VerboseCheckLib = $(VerboseCheckCLib) public.CheckHeader = $(CheckCHeader) public.VerboseCheckHeader = $(VerboseCheckCHeader) # # Check whether a program exists in the PATH # # \begin{doc} # \fun{CheckProg} # \verb+success = $(CheckProg )+ # # Checks whether the program \verb++ exists in your path. Will use the # \hyperfunn{ConfMsgChecking} and # \hyperfunn{ConfMsgResult} functions to describe the test and the outcome. # # \end{doc} # public.CheckProg(prog) = ConfMsgChecking(for $(prog)) WHERE = $(where $(quote-argv $(prog))) if $(WHERE) ConfMsgResult(found $(nth 0, $(WHERE))) return true else ConfMsgResult(FAILED - no $(prog) found) return false # # \begin{doc} # \section{Translating \code{autoconf} scripts} # Some of the functions described above are very similar to the ones present in \verb+autoconf+. # Below is a brief translation table for such functions. # \begin{description} # \itemidx{AC\_MSG\_CHECKING} is very similar to \hyperfun{ConfMsgChecking}. # \itemidx{AC\_MSG\_RESULT} is very similar to \hyperfun{ConfMsgResult}. # \itemidx{AC\_MSG\_WARN} is very similar to \hyperfun{ConfMsgWarn}. # \itemidx{AC\_MSG\_ERROR} is very similar to \hyperfun{ConfMsgError}. # \itemidx{AC\_TRY\_COMPILE} is somewhat similar to \hyperfun{TryCompileC}, # except the \hyperfun{TryCompileC} returns a boolean value and only works for \verb+C+. Similarly, # \itemidx{AC\_TRY\_LINK} is approximated by \hyperfun{TryLinkC}, and # \itemidx{AC\_TRY\_RUN} is approximated by \hyperfun{TryRunC}. # \end{description} # # \section{Predefined configuration tests} # A number of configuration tests are already included in the standard library. # In order to use them in your project, simply \verb+open+ (see Section~\ref{section:include}) the # corresponding build file in your \verb+OMakefile+ and the tests will run the first time \OMake{} # is executed. Note that it is not a problem to \verb+open+ these files from more than one place in # your project --- if you do that, the test will still run only once. # \end{doc} # omake-0.10.3/lib/configure/moncontrol.om0000644000175000017500000000103713177364666016615 0ustar gerdgerdopen configure/Configure # \begin{doc} # \subsection{Moncontrol configuration} # Add \verb+open configure/moncontrol+ line to your \verb+OMakefile+ to get access to the following # autoconfiguration variables. # \varlabel{MONCONTROL_AVAILABLE}{MONCONTROL\_AVAILABLE} A boolean flag telling whether the moncontrol # function is available in the standard C library. # # \end{doc} # .STATIC: MONCONTROL_AVAILABLE = false section MONCONTROL_AVAILABLE = $(VerboseCheckLib $(EMPTY), moncontrol) export MONCONTROL_AVAILABLE omake-0.10.3/lib/configure/posix_spawn.om0000644000175000017500000000105113177364666016771 0ustar gerdgerdopen configure/Configure # \begin{doc} # \subsection{Posix_spawn configuration} # Add \verb+open configure/posix_spawn+ line to your \verb+OMakefile+ to get access to the following # autoconfiguration variables. # \varlabel{POSIX_SPAWN_AVAILABLE}{POSIX\_SPAWN\_AVAILABLE} A boolean flag telling whether the posix_spawn # function is available in the standard C library. # # \end{doc} # .STATIC: POSIX_SPAWN_AVAILABLE = false section POSIX_SPAWN_AVAILABLE = $(VerboseCheckLib $(EMPTY), posix_spawn) export POSIX_SPAWN_AVAILABLE omake-0.10.3/lib/parse/0000755000175000017500000000000013177364666013216 5ustar gerdgerdomake-0.10.3/lib/parse/C/0000755000175000017500000000000013177364666013400 5ustar gerdgerdomake-0.10.3/lib/parse/C/Lex.install0000644000175000017500000001057413177364666015527 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) # # Lexer for C code # # # The types value keeps track of type definitions # public.types. = extends $(Map) # Initial base types $|void| = type_builtin $|char| = type_builtin $|int| = type_builtin $|float| = type_builtin $|double| = type_builtin # # GCC extensions # $|__builtin_va_list| = type public.const.add-type-name(v) = types = $(types.add $(v), type) export # # Keywords # public.keywords. = extends $(Map) $|auto| = tyclass $|break| = break $|case| = case $|const| = tyqual $|continue| = break $|default| = default $|do| = do $|else| = else $|enum| = enum $|extern| = tyclass $|for| = for $|goto| = goto $|if| = if $|inline| = tyclass $|long| = tymod $|register| = tyclass $|return| = return $|short| = tymod $|signed| = tyqual $|sizeof| = sizeof $|static| = tyclass $|struct| = struct $|switch| = switch $|typedef| = typedef $|union| = struct $|unsigned| = tyqual $|volatile| = tyqual $|while| = while $|asm| = asm # # GCC extensions # $|__attribute__| = __attribute__ $|__extension__| = __extension__ $|__const| = tyqual $|__volatile| = tyqual $|__inline| = tyclass $|__inline__| = tyclass $|__restrict| = tyqual $|__signed| = tyqual $|__asm__| = asm $|__asm| = asm # # Our extensions # $|__dll_callback| = callback $|__dll_hidden| = tyclass $|__tagged_union| = __tagged_union # # Operators # public.operators. = extends $(Map) $|(| = lparen $|)| = rparen $|[| = lbrack $|]| = rbrack $|{| = lbrace $|}| = rbrace $|->| = binop0 $|.| = binop0 $|!| = unop1 $|~| = unop1 $|++| = incop1 $|--| = incop1 $|*| = star $|&| = amp $|-| = minus $|+| = plus # |*| = binop2 $|/| = binop2 $|%| = binop2 # |+| = binop3 # |-| = binop3 $|<<| = binop4 $|>>| = binop4 $|<| = binop5 $|<=| = binop5 $|>=| = binop5 $|>| = binop5 $|==| = binop6 $|!=| = binop6 # |&| = binop7 $|^| = binop8 $|&&| = binop10 $|?| = quest $|:| = colon $|+=| = eqop13 $|-=| = eqop13 $|*=| = eqop13 $|/=| = eqop13 $|&=| = eqop13 $|^=| = eqop13 $|%=| = eqop13 $|<<=| = eqop13 $|>>=| = eqop13 $|=| = eq $|,| = comma $|;| = semi $|...| = elide operators = $(operators.add |, binop9) operators = $(operators.add ||, binop11) operators = $(operators.add $'|=', eqop13) ######################################################################## # The lexer # public.c_lexer. = extends $(Lexer) # # If all else fails, its a syntax error # other: . eprintln(Illegal character: $0) this.lex() # # Numbers # int: $'([[:digit:]]+|0x[[:xdigit:]]*)[UL]?[UL]?' Token.pair(int, $0) float: $'([[:digit:]]+[.][[:digit:]]*([eE][+-]?[[:digit:]]*)?|[.][[:digit:]]+([eE][+-]?[[:digit:]]*)?)L?' Token.pair(float, $0) # # Strings and chars # string: $'"(\\.|[^"])*"' Token.pair(string, $0) char: $''['](\\.|[^'])*[']'' Token.pair(char, $0) # # Names # id: $'[[:alpha:]_][[:alnum:]_]*' private.id = $0 if $(keywords.mem $(id)) Token.pair($(keywords.find $(id)), $(id)) elseif $(types.mem $(id)) Token.pair($(types.find $(id)), $(id)) else Token.pair(id, $(id)) # # Operators # op: $'[-+*/%^|&!~)(}{.<>?:=,;]|\[|\]|[|][|]|&&|<<|>>|->|++|--|[-+*/&^%<>=!|]=|<<=|>>=|[.][.][.]' Token.pair($(operators.find $0), $0) # # CPP directive # cpp: $'#[[:space:]]*[[:alpha:]](\\\n|[^\n])*' this.lex() line: $'#[[:space:]]*\([[:digit:]]+\)[[:space:]]*"\((\\.|[^"\n])*\)"(\\\n|[^\n])*' this.set-line($2, $1) this.lex() # # Ignore comments and whitespace # white: $'[[:space:]]+' this.lex() normal-comment: $'/[*]([*][^/]|[^*])*[*]/' this.lex() line-comment: $'//[^\n]*\n' this.lex() # # End of file # eof: $"\'" Token.unit(eof) omake-0.10.3/lib/parse/C/Parse.install0000644000175000017500000035212213177364666016047 0ustar gerdgerd# # Required version of omake # OMakeVersion(0.10.3, 0.10.3) # # Parser for C code # # \begin{doc} # \section{C Parser} # \cutname{c-parser.html} # # The standard library file \verb+parse/C/Parse.om+ implements a # parser for the C language. The following code fragment gives # an example of a function to parse a file. # # \begin{verbatim} # open parse/C/Parse # # parse-file(filename) = # prog = $(parser.parse-file prog, $(filename)) # ... # \end{verbatim} # # The value \verb+prog+ that is returned is derived from the # object \verb+Prog+~\ref{object:C/Parse::Prog}, which splits # the program into the following parts: 1) an array of definitions, # 2) a table of \verb+struct+ definitions, 3) a table of # \verb+enum+ definitions, and 4) a table of \verb+typedef+s. # # Each of the programs parts is defined through the following # objects in the form of an \emph{abstract syntax tree} (AST), # with methods for performing some operations like resolving type # definitions, printing out the tree, \textit{etc}. # # The AST is defined through the following classes, where we use # the notation \verb+C/Parse::+ to represent an # object in the C AST. # \end{doc} # open parse/C/Lex private. = semi = $";" space = $" " tab = $" " tnl = $(nl)$(tab) comma = $", " eof = $"\\'" empty[] = ######################################################################## # This is all the info we collect on the side. # public. = # # \begin{doc} # \obj{C/Parse::TypeTable} # Extends: \verb+Map+~\ref{object:Map} # # This object represents a table that maps type names to # \verb+Type+~\ref{object:C/Parse::Type} values. # \end{doc} # TypeTable. = extends $(Map) this. = name = type this.const. = to-string() = s = this.foreach(v, ty) => s = $(s)$"/* $(name) $(v) = $(ty.to-string); */$(nl)" export value $(s) # For constructing type names name-index = 0 # For prettier printing of struct names PRINT_NAME = false # Used to decide when removal of type qualifiers is allowed IS_POINTER = false IS_EXTERN = false public. = # # Are we parsing C++? # NOTE: only the C fragment of C++ and references are currently supported. # Cxx = false # # The public types and parser # public. = # # \begin{doc} # \obj{C/Parse::Base} # # The base class from which all parser objects are derived. # # Fields: # \begin{itemize} # \item \verb+loc : Location+~\ref{object:Location} the location of the item. # \end{itemize} # # Every parser item has a location, which is initialized to the value # of \verb+parse-loc+ at the time the item is created. # # \textbf{Note:} if you are defining new items manually, you must define # \verb+parse-loc+ manually. For example, here is the definition of # the method \verb+Type.reference()+. # # \begin{verbatim} # Type. = # class Type # ... # reference() = # parse-loc = $(this.loc) # return $(TypePoiunter.make $(this)) # \end{verbatim} # \end{doc} # Base. = class Base declare loc this.const. = make-loc() = loc = $(parse-loc) return $(this) array-to-string(l) = s = foreach(x => ..., $(l)) s = $(s)$(x.to-string) export value $(s) array-to-string-pre(l, pre) = s = foreach(x => ..., $(l)) s = $(s)$(pre)$(x.to-string) export value $(s) array-to-string-wrap(l, pre, post) = s = foreach(x => ..., $(l)) s = $(s)$(pre)$(x.to-string)$(post) export value $(s) array-to-string-term(l, term) = s = foreach(x => ..., $(l)) s = $(s)$(x.to-string)$(term) export value $(s) array-to-string-sep(l, sep) = s = sepx = foreach(x => ..., $(l)) s = $(s)$(sepx)$(x.to-string) sepx = $(sep) export value $(s) array-to-identifier-term(l, term) = s = foreach(x => ..., $(l)) s = $(s)$(x.to-identifier)$(term) export value $(s) array-to-identifier-sep(l, sep) = s = sepx = foreach(x => ..., $(l)) s = $(s)$(sepx)$(x.to-identifier) sepx = $(sep) export value $(s) ######################################################################## # A complete program # \begin{doc} # \obj{C/Parse::Prog} # Extends: \verb+Base+~\ref{object:C/Parse::Base}. # # The \verb+Prog+ object is used to represent the abstract # syntax tree for a C program. The program has four parts. # # \begin{itemize} # \item \verb+defs : Definition Array+~\ref{object:C/Parse::Definition} # is the list of declarations and definitions # in the program. # \item \verb+typedefs : TypeTable+~\ref{object:C/Parse::TypeTable} # is a table that maps type names to their definitions. # \item \verb+structs : TypeTable+~\ref{object:C/Parse::TypeTable} # is a table of structure definitions. # \item \verb+tagged-unions : TypeTable+~\ref{object:C/Parse::TypeTable} # is a table that maps ``tagged'' unions to their definitions. # A tagged union is a C union in which one integer field, the ``tag'', # specifies the variant. # \item \verb+enums : TypeTable+~\ref{object:C/Parse::TypeTable} # is a table that maps enumeration names to their definitions. # \end{itemize} # \end{doc} # Prog. = class Prog extends $(Base) this. = defs = $(empty) typedefs. = extends $(TypeTable) name = typedef structs. = extends $(TypeTable) name = struct tagged-unions. = extends $(TypeTable) name = __tagged_union enums. = extends $(TypeTable) name = enum # # Info about the anonymous types # type-names. = extends $(Map) anon-struct-types = $(empty) anon-enum-types = $(empty) this.const. = # # Adding to the tables # add-defs(defs) = this.defs = $(defs) return $(this) add-struct(name, info) = structs = $(structs.add $(name), $(info)) return $(this) add-tagged-union(name, info) = tagged-unions = $(tagged-unions.add $(name), $(info)) return $(this) add-enum(name, info) = enums = $(enums.add $(name), $(info)) return $(this) add-typedef(name, def) = typedefs = $(typedefs.add $(name), $(def)) return $(this) add-type-name(name, def) = type-names = $(type-names.add $(name), $(def)) return $(this) add-anon-struct-type(info) = anon-struct-types[] += $(info) return $(this) add-anon-enum-type(info) = anon-enum-types[] += $(info) return $(this) # # Print it out # to-string() = value $"""$(array-to-string-term $(defs), $(nl)) $(typedefs.to-string)""" # $(structs.to-string) # $(enums.to-string)""" # # This is the actual program # public.prog = $(Prog) public. = ######################################################################## # Operators # # \begin{doc} # \obj{C/Parse::Op} # Extends: \verb+Base+~\ref{object:C/Parse::Base}. # # The \verb+Op+ object represents an operator. # # Fields: # \begin{itemize} # \item \verb+op : String+ is the name of the operator # \end{itemize} # # \obj{C/Parse::Unop} # # Extends: \verb+C/Parse::Op+~\ref{object:C/Parse::Op}. # # Unary operators. # # \obj{C/Parse::Binop} # # Extends: \verb+C/Parse::Op+~\ref{object:C/Parse::Op}. # # \obj{C/Parse::Ternop} # # Extends: \verb+C/Parse::Op+~\ref{object:C/Parse::Op}. # # Ternary operators (in C, this is only \verb+exp ? exp : exp+). # # \end{doc} # Op. = class Op extends $(Base) this.op = this.const. = make(op) = this = $(make-loc) this.op = $(op) return $(this) to-string() = value $(op) Unop. = class Unop extends $(Op) Binop. = class Binop extends $(Op) Ternop. = class Ternop extends $(Op) ######################################################################## # Expressions # # \begin{doc} # \obj{C/Parse::Exp} # Extends: \verb+Base+~\ref{object:C/Parse::Base}. # # The base class for expressions. # # \obj{C/Parse::LiteralExp} # # Extends: \verb+C/Parse::Exp+~\ref{object:C/Parse::Exp}. # # A \verb+LiteralExp+ represents a constant. # # Fields: # # \begin{itemize} # \item \verb+val : String+ the string representation of the constant. # \end{itemize} # # \obj{C/Parse::CharExp} # # Extends: \verb+C/Parse::LiteralExp+~\ref{object:C/Parse::LiteralExp}. # # A character constant. The field \verb+val+ is the constant \emph{with} # quotations, for example \verb+'\n'+. # # \obj{C/Parse::IntExp} # # Extends: \verb+C/Parse::LiteralExp+~\ref{object:C/Parse::LiteralExp}. # # An integer constant. The field \verb+val+ is the constant in source # form, with any radix prefix and/or precision suffix, for example # \verb+0xabcdL+. # # \obj{C/Parse::FloatExp} # # Extends: \verb+C/Parse::LiteralExp+~\ref{object:C/Parse::LiteralExp}. # # An floating-pointer constant. The field \verb+val+ is the constant in source # form, for example \verb+31.415926e-1+. # # \obj{C/Parse::StringExp} # # Extends: \verb+C/Parse::LiteralExp+~\ref{object:C/Parse::LiteralExp}. # # A string constant. The field \verb+val+ is the constant in source # form, with quotes, for example \verb+"Hello world\n"+. # # \obj{C/Parse::IdExp} # # Extends: \verb+C/Parse::LiteralExp+~\ref{object:C/Parse::LiteralExp}. # # An identifier (a type or variable name). The field \verb+val+ is the # name of the identifier. # \end{doc} # Exp. = class Exp extends $(Base) this.const. = make-exp() = value $(make-loc) NoneExp. = class NoneExp extends $(Exp) this.const. = make() = make-exp() to-string() = LiteralExp. = class LiteralExp extends $(Exp) this. = val = this.const. = make(val) = this = $(make-exp) this.val = $(val) return $(this) to-string() = value $(val) CharExp. = class CharExp extends $(LiteralExp) IntExp. = class IntExp extends $(LiteralExp) FloatExp. = class FloatExp extends $(LiteralExp) StringExp. = class StringExp extends $(LiteralExp) IdExp. = class IdExp extends $(LiteralExp) # # Objects in the AST. # # \begin{doc} # \obj{C/Parse::Exp1} # # Extends: \verb+C/Parse::Exp+~\ref{object:C/Parse::Exp}. # # This is an expression with an operator an one subexpression. # # Fields: # # \begin{itemize} # \item \verb+op : Unop+~\ref{object:C/Parse::Unop} the operator. # \item \verb+arg : Exp+~\ref{object:C/Parse::Exp} the subexpression. # \end{itemize} # # \obj{C/Parse::PreExp1} # # Extends: \verb+C/Parse::Exp1+~\ref{object:C/Parse::Exp1}. # # A pre-operation, such as \verb+--i+. # # \obj{C/Parse::PostExp1} # # Extends: \verb+C/Parse::Exp1+~\ref{object:C/Parse::Exp1}. # # A post-operation, such as \verb+i--+. # # \end{doc} # Exp1. = class Exp1 extends $(Exp) this. = op = arg = this.const. = make(op, arg) = this = $(make-exp) this.op = $(Unop.make $(op)) this.arg = $(arg) return $(this) to-string() = value $"$(op.to-string)$(arg.to-string)" PreExp1. = class PreExp1 extends $(Exp1) PostExp1. = class PostExp1 extends $(Exp1) this.const. = to-string() = return $"$(arg.to-string)$(op.to-string)" # # \begin{doc} # \obj{C/Parse::Exp2} # # Extends: \verb+C/Parse::Exp+~\ref{object:C/Parse::Exp}. # # An expression with an operator and two subexpressions, # for example, \verb+1 - 2+. # # Fields: # # \begin{itemize} # \item \verb+op : Binop+~\ref{object:C/Parse::Binop} the operator. # \item \verb+arg1, arg2 : Exp+~\ref{object:C/Parse::Exp} the subexpressions. # \end{itemize} # # \obj{C/Parse::AssignExp} # # Extends: \verb+C/Parse::Exp2+~\ref{object:C/Parse::Exp2}. # # This represents an assignment operation. The operator # can be either a simple assignment \verb+x = 1+, or # involve computation \verb+x *= 2+. # # \end{doc} # Exp2. = class Exp2 extends $(Exp) this. = op = arg1 = arg2 = this.const. = make(op, arg1, arg2) = this = $(make-exp) this.op = $(Binop.make $(op)) this.arg1 = $(arg1) this.arg2 = $(arg2) return $(this) to-string() = value $"$(arg1.to-string) $(op.to-string) $(arg2.to-string)" AssignExp. = class AssignExp extends $(Exp2) # # \begin{doc} # \obj{C/Parse::Exp3} # # Extends: \verb+C/Parse::Exp+~\ref{object:C/Parse::Exp}. # # This represents an expression with two operators and three # subexpressions. In plain C, there is only one expression # of this form, \verb+exp ? exp : exp+. The first operator # is \verb+?+ and the second is \verb+:+. # # Fields: # # \begin{itemize} # \item \verb+op1, op2 : Ternop+~\ref{object:C/Parse::Ternop}. # \item \verb+arg1, arg2, arg3 : Exp+~\ref{object:C/Parse::Exp}. # \end{itemize} # \end{doc} # Exp3. = class Exp3 extends $(Exp) this. = op1 = op2 = arg1 = arg2 = arg3 = this.const. = make(arg1, op1, arg2, op2, arg3) = this = $(make-exp) this.op1 = $(Ternop.make op1) this.op2 = $(Ternop.make op2) this.arg1 = $(arg1) this.arg2 = $(arg2) this.arg3 = $(arg3) return $(this) to-string() = value $"$(arg1.to-string) $(op1.to-string) $(arg2.to-string) $(op2.to-string) $(arg3.to-string)" # # Other expressions # # \begin{doc} # \obj{C/Parse::ParensExp} # # Extends: \verb+C/Parse::Exp+~\ref{object:C/Parse::Exp}. # # A parenthesized expression. # # Fields: # # \begin{itemize} # \item \verb+exp : Exp+~\ref{object:C/Parse::Exp} the subexpression. # \end{itemize} # \end{doc} # ParensExp. = class ParensExp extends $(Exp) this. = exp = this.const. = make(exp) = this = $(make-exp) this.exp = $(exp) return $(this) to-string() = return $"($(exp.to-string))" # # \begin{doc} # \obj{C/Parse::StmtExp} # # Extends: \verb+C/Parse::Exp+~\ref{object:C/Parse::Exp}. # # (GCC-specific) A compound statement expression, # for example \verb+({ x = 1; y = 2; })+. # # Fields: # # \begin{itemize} # \item \verb+stmt : Exp+~\ref{object:C/Parse::Exp} the statement, # represented as an expression. # \end{itemize} # \end{doc} # StmtExp. = class StmtExp extends $(Exp) this. = stmt = this.const. = make(stmt) = this = $(make-exp) this.stmt = $(stmt) return $(this) to-string() = return $"($(stmt.to-string))" # # \begin{doc} # \obj{C/Parse::SubscriptExp} # # Extends: \verb+C/Parse::Exp+~\ref{object:C/Parse::Exp}. # # A subscripting operation \verb+arg1[arg2]+. # # Fields: # # \begin{itemize} # \item \verb+arg1, arg2 : Exp+~\ref{object:C/Parse::Exp} the subexpressions. # \end{itemize} # \end{doc} # SubscriptExp. = class SubscriptExp extends $(Exp) this. = arg1 = arg2 = this.const. = make(arg1, arg2) = this = $(make-exp) this.arg1 = $(arg1) this.arg2 = $(arg2) return $(this) to-string() = value $"$(arg1.to-string)[$(arg2.to-string)]" # # \begin{doc} # \obj{C/Parse::ApplyExp} # # Extends: \verb+C/Parse::Exp+~\ref{object:C/Parse::Exp}. # # A function application \verb+f(arg1, ..., argN)+. # # Fields: # # \begin{itemize} # \item \verb+var : String+ the function. # \item \verb+args : Exp Array+~\ref{object:C/Parse::Exp} the arguments to the function. # \end{itemize} # \end{doc} # ApplyExp. = class ApplyExp extends $(Exp) this. = var = args = this.const. = make(var, args) = this = $(make-exp) this.var = $(var) this.args = $(args) return $(this) to-string() = value $"$(var)($(array-to-string-sep $(args), $(comma)))" # # \begin{doc} # \obj{C/Parse::CastExp} # # Extends: \verb+C/Parse::Exp+~\ref{object:C/Parse::Exp}. # # A type cast \verb+(type) exp+. # # Fields: # # \begin{itemize} # \item \verb+type : Type+~\ref{object:C/Parse::Type} the type. # \item \verb+exp : Exp+~\ref{object:C/Parse::Exp} the expression to be cast. # \end{itemize} # \end{doc} # CastExp. = class CastExp extends $(Exp) this. = type = exp = this.const. = make(type, exp) = this = $(make-exp) this.type = $(type) this.exp = $(exp) return $(this) to-string() = value $"($(type.to-string)) $(exp.to-string)" # # \begin{doc} # \obj{C/Parse::SizeofExp} # # Extends: \verb+C/Parse::Exp+~\ref{object:C/Parse::Exp}. # # A \verb+sizeof+ expression, for example \verb+sizeof(int)+ or \verb+sizeof(1 - 2)+. # # Fields: # # \begin{itemize} # \item \verb+val : Type+~\ref{object:C/Parse::Type} or \verb+val : Exp+~\ref{object:C/Parse::Exp}. # \end{itemize} # \end{doc} # SizeofExp. = class SizeofExp extends $(Exp) this. = val = this.const. = make(val) = this = $(make-exp) this.val = $(val) return $(this) to-string() = value $"sizeof($(val.to-string))" ######################################################################## # Initializers # # \begin{doc} # \obj{C/Parse::Initializer} # Extends: \verb+Base+~\ref{object:C/Parse::Base}. # # An initial value. # # \obj{C/Parse::InitExp} # Extends: \verb+C/Parse::Initializer+~\ref{object:C/Parse::Initializer}. # # An expression initializer. In plain C, the expression must be constant, # for example the expression \verb+1 - 2+ in \verb+int x = 1 - 2+. # # Fields: # \begin{itemize} # \item \verb+exp : Exp+~\ref{object:C/Parse::Exp} the expression. # \end{itemize} # # \obj{C/Parse::InitArray} # Extends: \verb+C/Parse::Initializer+~\ref{object:C/Parse::Initializer}. # # An array initializer, for example \verb+int x[] = { 1, 2, 3 };+. # # Fields: # \begin{itemize} # \item \verb+exp_list : Initializer Array+~\ref{object:C/Parse::Initializer} the list of initial values. # \end{itemize} # # \obj{C/Parse::InitField} # Extends: \verb+C/Parse::Initializer+~\ref{object:C/Parse::Initializer}. # # A structure field initializer (GCC-specific). The following definition # contains field initializers of the form \verb+ : +. # # \begin{verbatim} # struct foo { int x, y; }; # struct foo z = { y: 1; x: 1 + 2; }; # \end{verbatim} # # Fields: # \begin{itemize} # \item \verb+name : String+ the identifier. # \item \verb+exp : Initializer+~\ref{object:C/Parse::Initializer} the initializer. # \end{itemize} # \end{doc} # Initializer. = class Initializer extends $(Base) this.const. = make-init() = make-loc() to-string() = value Initializer InitExp. = class InitExp extends $(Initializer) this.exp = this.const. = make(exp) = this = $(make-init) this.exp = $(exp) return $(this) to-string() = value $"/*InitExp*/ $(exp.to-string)" InitArray. = class InitArray extends $(Initializer) this.exp_list = this.const. = make(exp_list) = this = $(make-init) this.exp_list = $(exp_list) return $(this) to-string() = value $"/*InitArray*/{ ... }" InitField. = class InitField extends $(Initializer) this. = name = exp = this.const. = make(name, exp) = this = $(make-init) this.name = $(name) this.exp = $(exp) return $(this) to-string() = value $"/*InitField*/ $(name): $(exp.to-string)" ######################################################################## # Statements # # \begin{doc} # \obj{C/Parse::Stmt} # Extends: \verb+Base+~\ref{object:C/Parse::Base}. # # A statement. # # \obj{C/Parse::EmptyStmt} # Extends: \verb+C/Parse::Stmt+~\ref{object:C/Parse::Stmt}. # # An empty statement, \verb+;+. # # \obj{C/Parse::ExpStmt} # Extends: \verb+C/Parse::Stmt+~\ref{object:C/Parse::Stmt}. # # An expression statement, for example \verb+1;+. # # Fields: # \begin{itemize} # \item \verb+exp : Exp+~\ref{object:C/Parse::Exp} the expression # \end{itemize} # \end{doc} # Stmt. = class Stmt extends $(Base) this.const. = make-stmt() = make-loc() EmptyStmt. = class EmptyStmt extends $(Stmt) this.const. = make() = make-stmt() to-string() = return $";" ExpStmt. = class ExpStmt extends $(Stmt) this. = exp = this.const. = make(exp) = this = $(make-stmt) this.exp = $(exp) return $(this) to-string() = return $"$(exp.to-string);" # # \begin{doc} # \obj{C/Parse::DefaultStmt} # Extends: \verb+C/Parse::Stmt+~\ref{object:C/Parse::Stmt}. # # Labels and cases are modeled as statements. # The \verb+DefaultStmt+ represents the syntax \verb+default:+. # # Fields: # \begin{itemize} # \item \verb+exp : Exp+~\ref{object:C/Parse::Exp} the expression # \end{itemize} # # \obj{C/Parse::CaseStmt} # Extends: \verb+C/Parse::Stmt+~\ref{object:C/Parse::Stmt}. # # Labels and cases are modeled as statements. # The \verb+CaseStmt+ represents the syntax \verb+case :+. # # Fields: # \begin{itemize} # \item \verb+exp : Exp+~\ref{object:C/Parse::Exp} the expression. # \end{itemize} # # \obj{C/Parse::LabelStmt} # Extends: \verb+C/Parse::Stmt+~\ref{object:C/Parse::Stmt}. # # Labels and cases are modeled as statements. # The \verb+LabelStmt+ represents the syntax \verb+